在其他工作表上查找值并复制整行 [英] Find Value on other sheet and copy entire row

问题描述

**您好。我在一个项目上工作，我需要一些帮助。我不熟悉VBA，所以任何你的帮助将是非常有益的。

**Hello. I'm working on one project and I need some help. I'm not familiar with VBA so any your help will be very helpfull.

这是我要做的：

在sheet2上，在单元格A1中，我写一些值，何时我点击按钮，它必须开始在sheet1的列D上搜索这个值，如果它会找到这个值，它将复制sheet2上的第3行中的整个行

On sheet2, in cell A1 I write some value and when I click on the button and it have to start searching for this value on sheet1's Column D than if it will find this value, it will copy entire row(s) in 3rd row on sheet2

我发现这个代码，它工作正常，但是我需要为我编辑它。

I found this code and it is working fine but I need to edit it for me.

提前感谢。

Sub SearchForString()

    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer

    On Error GoTo Err_Execute

    'Start search in row 4
    LSearchRow = 4

    'Start copying data to row 2 in Sheet2 (row counter variable)
    LCopyToRow = 2

    While Len(Range("A" & CStr(LSearchRow)).Value) > 0

        'If value in column E = "Mail Box", copy entire row to Sheet2
        If Range("E" & CStr(LSearchRow)).Value = "D1" Then

            'Select row in Sheet1 to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy

            'Paste row into Sheet2 in next row
            Sheets("Sheet2").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste

            'Move counter to next row
            LCopyToRow = LCopyToRow + 1

            'Go back to Sheet1 to continue searching
            Sheets("Sheet1").Select

        End If

        LSearchRow = LSearchRow + 1

    Wend

    'Position on cell A3
    Application.CutCopyMode = False
    Range("A3").Select

    MsgBox "All matching data has been copied."

    Exit Sub

Err_Execute:
    MsgBox "An error occurred."

End Sub

推荐答案

以更快更可靠的方式推出另一种方式来获得想要完成的任务。以下代码使用内置的Excel函数，而不是VBA循环。

Just to put out another way to get what you want done, in a faster more reliable way. The following code uses built in Excel function, instead of VBA loops.

Sub FilterAndCopy()

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

Dim rngLastCell As Range
Dim sh As Worksheet, sh2 As Worksheet
Dim lnglastrow1 As Long
Dim lnglastcolumn1 As Long



Set sh = ThisWorkbook.Sheets("Sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")

lnglastrow1 = sh.Cells(Rows.Count, "A").End(xlUp).Row ' Replace "A" With column that has the most Rows
lnglastcolumn1 = sh.Cells(1, Columns.Count).End(xlToLeft).Column
Set rngLastCell = sh.Cells(lnglastrow1 , lnglastcolumn1 )

With sh.Range("A1", rngLastCell)

'Replace the number in the field section with your Columns number
    .AutoFilter , _
        Field:=4, _
        Criteria1:=sh2.Range("A1").Value

    .Copy sh2.Range("A3")

End With

Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

End Sub

这篇关于在其他工作表上查找值并复制整行的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！