比较两个工作簿之间的行差异

Question

我在比较两个工作簿之间的行时遇到问题。我想比较两个工作簿中的行，并将主工作簿中的更新数据添加到另一个工作簿中的下一个空白行。但是，我的代码只复制所有行而不是只复制新行。

Sub test()
  Dim varSheetA As Variant
  Dim varSheetB As Variant
  Dim strRangeToCheck As String
  Dim strRangeToC As String
  Dim iRow As Long
  Dim iRow2 As Long
  Dim iCol As Long
  Dim wbkA As Workbook
  Dim eRow As Long
  Dim cfind As Range
  Dim c As Range
  Dim rng As Range
  Dim i, j, k As Integer
  Dim newarr As String
  Dim existarr As String
  Dim b As Boolean
  Set wbkA = Workbooks.Open(Filename:="C:\Users\mandy\Desktop\fortest.xlsx")
  strRangeToCheck = "A:C"
  strRangeToC = "C:E"
  varSheetA = wbkA.Worksheets("Sheet1").Range(strRangeToCheck)
  varSheetB = ThisWorkbook.Worksheets("Sheet1").Range(strRangeToC)

  For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
    For iRow2 = LBound(varSheetB, 1) To UBound(varSheetB, 1)
      For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
        If ThisWorkbook.Sheets("Sheet1").Range("C").Value = wbkA.Sheets("Sheet1").Range("A") Then
          If ThisWorkbook.Sheets("Sheet1").Range("D").Value = wbkA.Sheets("Sheet1").Range("B") Then
            If ThisWorkbook.Sheets("Sheet1").Range("E").Value = wbkA.Sheets("Sheet1").Range("C") Then
              If varSheetA(iRow, iCol).EntireRow = varSheetB(iRow, iCol).EntireRow Then
              ' Cells are identical.
              ' Do nothing
              Else
                If ThisWorkbook.Sheets("Sheet1").Range("C" & iRow2).Value = wbkA.Sheets("Sheet1").Range("A" & iRow).Value Then
                  b = False
                Else
                  If ThisWorkbook.Sheets("Sheet1").Range("D" & iRow2).Value = wbkA.Sheets("Sheet1").Range("B" & iRow).Value Then
                    b = False
                  Else
                    If ThisWorkbook.Sheets("Sheet1").Range("E" & iRow2).Value = wbkA.Sheets("Sheet1").Range("C" & iRow).Value Then
                      b = False
                    Else
                      eRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 3).End(xlUp).Row + 1
                      ThisWorkbook.Sheets("Sheet1").Range("C" & eRow & ":E" & eRow).EntireRow = wbkA.Sheets("Sheet1").Range("A" & iRow & ":C" & iRow).EntireRow
                      Exit For
                    End If
                  End If
                End If
              End If
            End If
          End If
        End If
      Next
    Next
  Next
  wbkA.Close savechanges:=False
End Sub

enter image description here

Answer 1

你能试试这个吗：

Sub test()

    Dim WbA As Workbook
    Set WbA = ActiveWorkbook

    Dim WbB As Workbook
    Set WbB = Workbooks.Open(Filename:="C:\Users\mandy\Desktop\fortest.xlsx")

    Dim SheetA As Worksheet
    Dim SheetB As Worksheet
    SheetA = WbA.Sheets("Sheet1")
    SheetB = WbB.Sheets("Sheet1")

    Dim eRowA As Integer
    Dim eRowB As Integer
    eRowA = (SheetA.Cells(SheetA.Rows.Count, 1).End(xlUp).Row) 'Last line with data in Workbook A (ActiveWorkbook)
    eRowB = (SheetB.Cells(SheetB.Rows.Count, 1).End(xlUp).Row)  'Last line with data in Workbook B (Opened Workbook)

    Dim RowA As Integer
    Dim RowB As Integer

    For RowA = 1 To eRowA
        For RowB = 1 To eRowB
            If SheetA.Rows(RowA) = SheetB.Rows(RowB) Then
                'Do nothing
            Else
                SheetB.Rows(RowB).Copy
                SheetA.Rows(eRowA + 1).Paste
            End If
        Next RowB
    Next RowA

    WbB.Close (False)

End Sub

这没有经过测试，但我认为它应该可以工作。我会很高兴收到反馈。