在工作表之間複製和粘貼行

Question

我想要實現的是根據特定條件將數據從WS1複製到WS3。

我有2個工作表：

WS1 = RAW DATA 
WS2 = ATLAS DATA 

的列中的兩個有獨特的標識符。我想要做的是創建WS3=Reconciliation。然後在WS2中查找WS1中的值。當找到匹配我想從WS1行（S）複製到WS3所有 我已經逆向工程一些代碼，根據您的問題的描述與一個想出了下面

Sub CopyAndPaste() 
Dim x As String, CpyRng As Range 
Dim mFIND As Range, mFIRST As Range 

    With Sheets("RAW DATA") 
     Range("A:A").Select 
     On Error Resume Next 
End With 
With Sheets("ATLAS DATA") 
     Set mFIND = .Range("A:A").Find(x, LookIn:=xlValues, LookAt:=xlWhole) 
     If Not mFIND Is Nothing Then 
      Set CpyRng = mFIND 
      Set mFIRST = mFIND 

      Do 
       Set CpyRng = Union(CpyRng, mFIND) 
       Set mFIND = .Range("A:A").FindNext(mFIND) 
      Loop Until mFIND.Address = mFIRST.Address 

      CpyRng.EntireRow.Copy Sheets("Rec").Range("A" & Rows.Count).End(xlUp).Offset(1) 
     End If 
    End With 
End Sub 

Answer 1

;試試這個

Option Explicit 

Sub CopyAndPaste() 
Application.ScreenUpdating = False 

    Dim i As Long, j As Long, lastRow1 As Long, lastRow2 As Long, cnt As Long 
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet 
    Set ws1 = ActiveWorkbook.Sheets("RAW DATA") 
    Set ws2 = ActiveWorkbook.Sheets("ATLAS DATA") 
    Set ws3 = ActiveWorkbook.Sheets("Reconciliation") 

    lastRow1 = ws1.Range("A" & Rows.Count).End(xlUp).Row 
    lastRow2 = ws2.Range("A" & Rows.Count).End(xlUp).Row 
    cnt = 1 

    For i = 1 To lastRow1 
     For j = 1 To lastRow2 
      If StrComp(CStr(ws2.Range("A" & j).Value), _ 
         CStr(ws1.Range("A" & i).Value), _ 
         vbTextCompare) = 0 Then 
         ws1.Activate 
         ws1.Rows(i).Select 
         Selection.Copy 
         ws3.Activate 
         ws3.Range("A" & cnt).Select 
         Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme 
         Application.CutCopyMode = False 
         cnt = cnt + 1 
      End If 
     Next j 
    Next i 
Application.ScreenUpdating = True 
End Sub