VBA代碼比較兩個基於KEY的工作表

Question

我正在根據一個鍵比較2個工作表，並將結果寫在新工作簿中。 KEY列為A。

2個工作簿是“今天”和“昨天”文件。

我需要比較今天的文件和昨天的文件。 以下是我的情況：

1. 如果兩個工作表中的KEY都匹配，並且對應的KEY的所有列都匹配（B：E），則在F列中，該值應為NO CHANGE

2. 如果兩個工作表中的KEY都匹配，並且與KEY（B：E）相對應的任何列都不匹配，則F列的值應為CHANGED

3. 如果KEY不匹配，則F列應具有值NEW RECORD

下面是我的代碼編寫邏輯覆蓋了我的值，並且它們是從昨天的文件中寫入記錄，而不是從今天的文件中寫入記錄：

'ASSUMPTIONS:
'Data begins in cell A1 of each worksheet
'Data is continuous (does not have blank rows or columns)
'Comparison Key should be in column A of each sheet and should NEVER be blank


    Sub CompareArrays()

    Dim BookOne As String, BookTwo As String, BookThree As String
    Dim WorkbookOne As Workbook, WorkbookTwo As Workbook, WorkbookThree    As               Workbook
Dim SheetOne As Worksheet, SheetTwo As Worksheet, SheetThree As Worksheet


Dim Keytocompare1 As String
Dim Keytocompare2 As String
Dim Keytocompare3 As String
Dim Keytocompare4 As String
Dim Keytocompare5 As String

Sheet1.Cells.ClearContents

'Select Path for First Workbook


MsgBox "Select Today's Common Customer File"

With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Title = "SELECT BOOK ONE"
    .Show
    BookOne = .SelectedItems(1)
End With


'Select Path for Second Workbook

MsgBox "Select Yesterday's Common Customer File"

With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Title = "SELECT BOOK TWO"
    .Show
    BookTwo = .SelectedItems(1)
End With


'Select Path for Output Workbook

MsgBox "Select Output Common Customer File"

With Application.FileDialog(msoFileDialogFilePicker)
    .AllowMultiSelect = False
    .Title = "SELECT BOOK THREE"
    .Show
    BookThree = .SelectedItems(1)
End With

Application.Workbooks.Open BookOne
Set SheetOne = ActiveWorkbook.Worksheets("Sheet1") '



Application.Workbooks.Open BookTwo
Set SheetTwo = ActiveWorkbook.Worksheets("Sheet1") '


Application.Workbooks.Open BookThree
Set SheetThree = ActiveWorkbook.Worksheets("Sheet1") '


Windows("Today.xlsx").Activate
Sheets("Sheet1").Select

Range("A1").Select

Do While ActiveCell.Value <> ""

    Keytocompare1 = ActiveCell.Value
    Keytocompare2 = ActiveCell.Offset(0, 1).Value
    Keytocompare3 = ActiveCell.Offset(0, 2).Value
    Keytocompare4 = ActiveCell.Offset(0, 3).Value
    Keytocompare5 = ActiveCell.Offset(0, 4).Value

    Windows("yesterday.xlsx").Activate
    Sheets("Sheet1").Select
    Range("A1").Select

    Do While ActiveCell.Value <> ""
     If ActiveCell.Value = Keytocompare1 Then
        If ((ActiveCell.Offset(0, 1).Value = Keytocompare2) And (ActiveCell.Offset(0, 2).Value = Keytocompare3) And (ActiveCell.Offset(0, 3).Value = Keytocompare4) And (ActiveCell.Offset(0, 4).Value = Keytocompare5)) Then

        Windows("Output.xlsx").Activate
        Sheets("Sheet1").Select
        Range("A1").Select


        ActiveCell.Offset(0, 1).Value = Keytocompare2
        ActiveCell.Offset(0, 2).Value = Keytocompare3
        ActiveCell.Offset(0, 3).Value = Keytocompare4
        ActiveCell.Offset(0, 4).Value = Keytocompare5
        ActiveCell.Offset(0, 5).Value = "No Change"

        Else

        Windows("Output.xlsx").Activate
        Sheets("Sheet1").Select
        Range("A1").Select

        ActiveCell.Offset(0, 1).Value = Keytocompare2
        ActiveCell.Offset(0, 2).Value = Keytocompare3
        ActiveCell.Offset(0, 3).Value = Keytocompare4
        ActiveCell.Offset(0, 4).Value = Keytocompare5
        ActiveCell.Offset(0, 5).Value = "Change"

        End If

     Else

      Windows("Output.xlsx").Activate
      Sheets("Sheet1").Select
      Range("A1").Select


      ActiveCell.Offset(0, 1).Value = Keytocompare2
      ActiveCell.Offset(0, 2).Value = Keytocompare3
      ActiveCell.Offset(0, 3).Value = Keytocompare4
      ActiveCell.Offset(0, 4).Value = Keytocompare5
      ActiveCell.Offset(0, 5).Value = "New Record"

     End If

Windows("Yesterday.xlsx").Activate
    Sheets("Sheet1").Select
'  Range("A2").Select

       ActiveCell.Offset(1, 0).Select

    Loop

Windows("Today.xlsx").Activate
    Sheets("Sheet1").Select
 '  Range("A2").Select

        ActiveCell.Offset(1, 0).Select

Loop


End Sub

你們能幫忙解決這個問題嗎？

Answer 1

假設所有3張紙都在當前工作簿中，我整理了一個示例VBA代碼（也進行了測試）。 您可以進行必要的更改和調整以設置為您的工作簿和工作表。 我已經結合使用Excel公式和二維數組從Excel讀取數據並寫回Excel。 請記住，當您從Excel讀取二維數組時，數組的下限為1，但是當您寫回Excel時，則需要啟動基於0的數組（行和列均適用）。

Public Sub CompareSheets()

    Dim wb As Workbook, xlRng As Range
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim Ar1, Ar2, Ar3, ArLoad()
    Dim lstR1!, lstR2!, iRow!, nRow!, str1$, str2$

    Set wb = ThisWorkbook
    Set ws1 = wb.Sheets(1):    Set ws2 = wb.Sheets(2):    Set ws3 = wb.Sheets(3)

    ' Get the last non blank cell in Column A in 1st and 2nd worksheets
    Set xlRng = ws3.Cells(1, 1)
    With xlRng
        .FormulaR1C1 = "=MAX((" & ws1.Name & "!C1<>"""")*(ROW(" & ws1.Name & "!C1)))"
        .FormulaArray = .Formula:   .Calculate:     lstR1 = .Value2
        .FormulaR1C1 = "=MAX((" & ws2.Name & "!C1<>"""")*(ROW(" & ws2.Name & "!C1)))"
        .FormulaArray = .Formula:   .Calculate:     lstR2 = .Value2
        .Clear
    End With

    ' Load into 2-d array data 1st and 2nd sheets
    Ar1 = ws1.Range("A1:E" & lstR1).Value
    Ar2 = ws2.Range("A1:E" & lstR2).Value


    ' Load Row number of 1st sheet that matches current row of second sheet
    Set xlRng = ws3.Range("A1:A" & lstR2)
    With xlRng
        .FormulaR1C1 = "=IFERROR(MATCH(" & ws2.Name & "!RC," & ws1.Name & "!C,0),0)"
        .Calculate:     Ar3 = .Value:   .Clear
    End With

    ReDim Preserve ArLoad(lstR2 - 1, 5)    ' this is the array that will be loaded into 3rd worksheet

    For iRow = 1 To UBound(Ar3, 1)
        For nCol = 1 To 5
            ArLoad(iRow - 1, nCol - 1) = Ar2(iRow, nCol)    ' Load ArLoad with data from ws2
        Next nCol

        ' Load Last Column of ArLoad with respective value depending if there is a change o
        If Ar3(iRow, 1) > 0 Then
            nRow = Ar3(iRow, 1) ' matching row number of 1st worksheet
            str2 = Ar2(iRow, 2) & Ar2(iRow, 3) & Ar2(iRow, 4) & Ar2(iRow, 5)
            str1 = Ar1(nRow, 2) & Ar1(nRow, 3) & Ar1(nRow, 4) & Ar1(nRow, 5)
            If str1 = str2 Then
                ArLoad(iRow - 1, 5) = "NO CHANGE"
            Else
                ArLoad(iRow - 1, 5) = "CHANGED"
            End If
        Else
            ArLoad(iRow - 1, 5) = "NEW RECORD"
        End If
    Next iRow

    ws3.Range("A1:F" & lstR2).Value = ArLoad

End Sub

Answer 2

試試看

'ASSUMPTIONS:
'Data begins in cell A1 of each worksheet
'Data is continuous (does not have blank rows or columns)
'Comparison Key should be in column A of each sheet and should NEVER be blank


Sub CompareArrays()

'   Sheet1.Cells.ClearContents                                           ' *********** UNKNOWN SHEET

    Dim filePick As FileDialog                                           ' set up filePicker object
    Set filePick = Application.FileDialog(msoFileDialogFilePicker)
    filePick.AllowMultiSelect = False


    MsgBox "Select Today's Common Customer File"
    filePick.Title = "SELECT BOOK ONE"
    filePick.Show
    Dim todayBookName As String
    todayBookName = filePick.SelectedItems(1)

    MsgBox "Select Yesterday's Common Customer File"
    filePick.Title = "SELECT BOOK TWO"
    filePick.Show
    Dim yesterBookName As String
    yesterBookName = filePick.SelectedItems(1)

    MsgBox "Select Output Common Customer File"
    filePick.Title = "SELECT BOOK THREE"
    filePick.Show
    Dim outputBookName As String
    outputBookName = filePick.SelectedItems(1)

    Set filePick = Nothing

    Dim todayBook As Workbook
    todayBook = Application.Workbooks.Open(todayBookName)

    Dim yesterBook As Workbook
    yesterBook = Application.Workbooks.Open(yesterBookName)

    Dim outputBook As Workbook
    outputBook = Application.Workbooks.Open(outputBookName)

' -------------------- process workbooks -----------------

    Dim recordStatus As String

    Dim yesterCell As Range
    Dim outputCell As Range


    Dim keyToCompare As Variant

    Dim i As Integer

    Dim todayCell As Range
    Set todayCell = todayBook.Sheets("Sheet1").Range("A1")            ' set pointer to cell A1

    Do While todayCell.Value <> ""

        keyToCompare = todayCell.Resize(1, 6).Value                   ' copy row of cells ... one extra cell at end
        keyToCompare = Application.Transpose(keyToCompare)            ' convert to
        keyToCompare = Application.Transpose(keyToCompare)            ' single dimension array

        Set yesterCell = yesterBook.Sheets("Sheet1").Range("A1")      ' set pointer to cell A1

        Do While yesterCell.Value <> ""                               ' process all non-blank cells

            Set outputCell = outputBook.Sheets("Sheet1").Range("A1")  ' set pointer to cell A1

            If yesterCell.Value = keyToCompare(1) Then
                If ( _
                        (yesterCell.Offset(0, 1).Value = keyToCompare(2)) _
                    And (yesterCell.Offset(0, 2).Value = keyToCompare(3)) _
                    And (yesterCell.Offset(0, 3).Value = keyToCompare(4)) _
                    And (yesterCell.Offset(0, 4).Value = keyToCompare(5))) Then

                    recordStatus = "No Change"
                Else
                    recordStatus = "Change"
                End If

            Else
                recordStatus = "New Record"
            End If

            keyToCompare(6) = recordStatus

            For i = 1 To 5                                          ' update 5 cells in output workbook
                outputCell.Offset(0, i).Value = keyToCompare(i + 1)
            Next i

            Set yesterCell = yesterCell.Offset(1, 0)                ' move pointer one cell down
            Set outputCell = outputCell.Offset(1, 0)                ' this is missing from original code

        Loop
        Set todayCell = todayCell.Offset(1, 0)
    Loop
End Sub