比较和复制从一个电子表格到另一个

Question

有两个Excel工作簿，主要和调查回复。

我必须遍历Survey Responses中的每一行，从第4列中选择值并将其与Master中的第4列进行比较。如果没有匹配，则将调查响应中的完整行复制到Master的末尾。 Master中第一次没有行，因此必须从Survey Responses中复制所有行。

调查回复

以下代码不会循环遍历所有行，如果我再次运行它，则会复制所有行而不执行比较。

'''''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