在其他工作表上查找值並複製整行

Question

**您好。我正在研究一個項目，我需要一些幫助。我不熟悉VBA，所以你的幫助將非常有幫助。

這是我想做什麼：

在Sheet2上，在單元格A1我寫了一些值，當我點擊按鈕，它必須開始在Sheet1中的列d尋找這個值比，如果它會找到這個值，它會複製sheet2上第三行的整行（s）

我發現這個代碼，它工作正常，但我需要爲我編輯它。

在此先感謝。

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 

我已經包括了對原代碼（你所要求的那些頂部）一些修改;但我已經評論了一切：看看它，讓我知道你是否有任何問題。

請注意，您的問題涉及第三行，但您的代碼從第二行開始。我已經讓它像你的代碼一樣（第一行復制是第2行）。