vba 在其他工作表上查找值并复制整行

Find Value on other sheet and copy entire row

提问by Sergi Khizanishvili

**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.

**你好。我正在做一个项目，我需要一些帮助。我不熟悉 VBA，因此您的任何帮助都会非常有帮助。

Here is What I want to do:

这是我想要做的：

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

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

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

我找到了这段代码，它运行良好，但我需要为我编辑它。

Thanks in advance.

提前致谢。

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

采纳答案by user2140261

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.

只是提出另一种方法来以更快更可靠的方式完成您想要的工作。以下代码使用内置 Excel 函数，而不是 VBA 循环。

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

回答by varocarbas

Here you have a corrected version of your code performing the requested actions:

在这里，您有执行请求操作的代码的更正版本：

Sub SearchForString()

    Dim LCopyToRow As Integer


    On Error GoTo Err_Execute


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

    Dim sheetTarget As String: sheetTarget = "sheet2"
    Dim sheetToSearch As String: sheetToSearch = "sheet1"
    Dim targetValue As String: targetValue = Sheets(sheetTarget).Range("A1").Value  'Value in sheet2!A1 to be searched in sheet1
    Dim columnToSearch As String: columnToSearch = "D"
    Dim iniRowToSearch As Integer: iniRowToSearch = 4
    Dim LSearchRow As Long 'As far as it is not clear the number of rows you will be considering, better relying on the long type
    Dim maxRowToSearch As Long: maxRowToSearch = 2000 'There are lots of rows, so better setting a max. limit

    If (Not IsEmpty(targetValue)) Then
        For LSearchRow = iniRowToSearch To Sheets(sheetToSearch).Rows.Count

            'If value in the current row (in columnToSearch in sheetToSearch) equals targetValue, copy entire row to LCopyToRow in sheetTarget 
            If Sheets(sheetToSearch).Range(columnToSearch & CStr(LSearchRow)).Value = targetValue Then

                'Select row in Sheet1 to copy
                Sheets(sheetToSearch).Rows(LSearchRow).Copy

                'Paste row into Sheet2 in next row
                Sheets(sheetTarget).Rows(LCopyToRow).PasteSpecial Paste:=xlPasteValues

                'Move counter to next row
                LCopyToRow = LCopyToRow + 1
            End If

            If (LSearchRow >= maxRowToSearch) Then
                Exit For
            End If

        Next LSearchRow

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

        MsgBox "All matching data has been copied."
    End If

    Exit Sub

Err_Execute:
    MsgBox "An error occurred."

End Sub

I have included some modifications on the original code (on top of the ones you requested); but I have commented everything: take a look at it and let me know if you have any question.

我对原始代码进行了一些修改（在您要求的代码之上）；但我已经评论了所有内容：看看它，如果您有任何问题，请告诉我。

Note that your question refers the third row but your code starts from the second one. I have let it as it was in your code (first row to copy is row number 2).

请注意，您的问题是指第三行，但您的代码从第二行开始。我已经让它在您的代码中保持原样（要复制的第一行是第 2 行）。