使用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