Question

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

这是我想做的事：

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

我找到了这段代码并且工作正常但我需要为我编辑它。

提前致谢。

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

Answer 1

此处您有执行所请求操作的代码的更正版本：

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

我在原始代码中包含了一些修改（在你要求的代码之上）;但我已经评论了所有内容：看看它，如果您有任何疑问，请告诉我。

请注意，您的问题是第三行，但您的代码是从第二行开始的。我已经把它放在你的代码中了（复制的第一行是第2行）。

Answer 2

只是以更快更可靠的方式推出另一种方式来获得你想要的东西。以下代码使用内置的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

在另一个工作表上查找值并复制整行

2 个答案: