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

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

这是我想要做的：

在sheet2上，在单元格A1中，我写了一些值，当我点击button时，它必须开始在sheet1的列D上search这个值，如果它能够find这个值，它会复制第三行中的整行Sheet2中

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

提前致谢。

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

只是想出另外一种方法，以更快更可靠的方式获得你想要完成的任务。 下面的代码使用内置的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 

Answer 2

在这里你有一个修正版本的代码执行请求的操作：

 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 

我已经在原始代码中join了一些修改（在你要求的代码之上）。 但是我已经评论了一切：看看它，让我知道，如果你有任何问题。

请注意，您的问题涉及第三行，但您的代码从第二行开始。 我已经让它像你的代码（复制的第一行是行号2）。