2

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

这是我想要做的：

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

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

提前致谢。

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
4

2 回答 2

0

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

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 行）。

于 2013-07-06T09:45:41.410 回答
0

只是为了以更快更可靠的方式推出另一种方式来完成您想要完成的事情。以下代码使用内置 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
于 2013-07-06T17:46:19.023 回答