使用vba宏比較和複製來自2個不同的電子表格

Question

我在Excel中苦苦尋找下面的宏。情景：有2個優秀的項目，第1個：主人和第2個調查回答。我必須遍歷Survey Responses excel中的每一行，然後爲每一行選擇第四列的值，並將其與整個主Excel中的第四列進行比較。如果不匹配，則將完整的行從Survey Responses excel複製到Master Excel的末尾。首次在Master Excel中不會有行，因此所有行都必須從Survey Survey Excel中複製。

Survey Responses Excel

下面的代碼不會遍歷所有的行，如果我運行它第二次仍然會將所有行，而不進行比較。

Here is the code what I am trying to use: 


'''''Define Object for Target Workbook 
Dim Target_Workbook As Workbook 
Dim Source_Workbook As Workbook 
Dim Source_Path As String 


'''''Assign the Workbook File Name along with its Path 
Source_Path = "C:\Users\Survey Responses\Survey Response.xls" 

Set Source_Workbook = Workbooks.Open(Source_Path) 
Set Target_Workbook = ThisWorkbook 


'''''With Source_Workbook object now, it is possible to pull any data from it 
'''''Read Data from Source File 


'''''Logic to select unique rows only 
Dim rngSource As Range, rngTarget As Range, cellSource As Range, cellTarget As Range 

Set rngSource = Source_Workbook.Sheets(1).Range("Responses") 
Set rngTarget = Target_Workbook.Sheets(2).Range("Responses") 

Dim rowNr_target As Integer, Rng As Range 


With Target_Workbook.Sheets(2) 
    rowNr_target = .Cells(.Rows.Count, "A").End(xlUp).Row 
End With 

Dim counter As Integer, found As Boolean, inner_counter As Integer 
counter = 1 

For Each cellSource In rngSource.Rows 
'On Error Resume Next 

    If cellSource.Cells(counter, 1).Value = "" Then 
     Exit For 
    End If 

    found = False 

    inner_counter = 1 

    For Each cellTarget In rngTarget.Rows 

     If cellTarget.Cells(inner_counter, 1).Value = "" Then 
      Exit For 
     End If 

     ''''test = Application.WorksheetFunction.VLookup(test1, rngTarget, 1, False) 
     If (cellSource.Cells(counter, 4) = cellTarget.Cells(inner_counter, 4)) Then 
      found = True 
      Exit For 
     End If 

     inner_counter = inner_counter + 1 

    Next 

    If (found = False) Then 
     cellSource.EntireRow.Copy 

     If (rowNr_target > 1) Then 
      rngTarget.Rows(rowNr_target + 1).Insert 
     Else 
      rngTarget.Rows(rowNr_target).Insert 
     End If 

     rowNr_target = rowNr_target + 1 
    End If 

    counter = counter + 1 
'On Error GoTo 0 

Next 

'''''Target_Workbook.Sheets(2).Range("Responses").Value = Source_data 


'''''Close Target Workbook 
Source_Workbook.Save 
Target_Workbook.Save 
''''Source_Workbook.Close False 

'''''Process Completed 
MsgBox "Task Completed" 

---

更新代碼：

Dim cel As Range 
Dim rng As Range 
Dim r As Range 
Dim lastrow As Long 

Dim Target_Workbook As Workbook 
Dim Source_Workbook As Workbook 
Dim Source_Path As String 


'''''Assign the Workbook File Name along with its Path 
Source_Path = "C:\Users\Survey Responses\Survey Response.xls" 
Set Source_Workbook = Workbooks.Open(Source_Path) 
Set Target_Workbook = ThisWorkbook 

Dim rngSource As Range, rngTarget As Range, cellSource As Range, cellTarget As Range 

Set rngSource = Source_Workbook.Sheets(1).Range("Responses") 
Set rngTarget = Target_Workbook.Sheets(2).Range("Responses") 


    With Target_Workbook.Sheets(2) 
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row 

     For Each cel In Source_Workbook.Sheets(1).Range("D:D") 

      If cel.Value = "" Then 
       Exit For 
      End If 

      Set r = .Range("D:D").Find(What:=cel, LookIn:=xlFormulas, _ 
      LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
      MatchCase:=False, SearchFormat:=False) 

      If r Is Nothing Then 
       cel.EntireRow.Copy 
       rngTarget.Rows(lastrow).Insert 
       ''If Not rng Is Nothing Then Set rng = Union(rng, cel) Else Set rng = cel 
      End If 

     Next cel 

     ''rng.Copy.Range("A" & lastrow).PasteSpecial xlPasteValues 

    End With 

'''''Close Target Workbook 
Source_Workbook.Save 
Target_Workbook.Save 
''''Source_Workbook.Close False 

'''''Process Completed 
MsgBox "Task Completed" 

Answer 1

這是未經測試的代碼，但它應該幫助你任何你已經有了。您需要調整範圍以適合自己，但它會循環顯示一張表並收集不存在的值，然後將它們複製到另一張表中。

試試這個，

Sub dave() 
Dim cel As Range 
Dim rng As Range 
Dim r As Range 
Dim lastrow As Long 


    With Sheets("Master") 
    lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row 
     For Each cel In Sheets("Sheet1").Range("D1:D22") 
      Set r = .Range("D:D").Find(What:=cel, LookIn:=xlFormulas, _ 
     LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ 
     MatchCase:=False, SearchFormat:=False) 
      If r Is Nothing Then 
       If Not rng Is Nothing Then Set rng = Union(rng, cel) Else Set rng = cel 
      End If 
     Next cel 
     rng.Copy 
     .Range("A" & lastrow).PasteSpecial xlPasteValues 
    End With 
End Sub