有没有办法比较两个 excel 工作簿中的值？

Question

大家好，祝你新年快乐！

我的目标是打开一个工作簿，比如说工作簿 A，我想将整个工作簿复制到工作簿 B，但是我想比较包含两个不同数字的两列。 因此，如果工作簿 A 具有这些数字，而工作簿 B 具有这些数字，则将整个行从工作簿 A 复制到工作簿 B，并覆盖它。 工作簿 B 总是产生新数据，我想在它覆盖当前行时保留它。

到目前为止，这是我的代码，它只是打开了一个对话框，显示 select 与哪个文件进行比较，并将整个工作表从工作簿 A 复制到工作簿 B，但我正在为此苦苦挣扎。 任何帮助，将不胜感激。

Option Explicit

Dim fullpath As String

Sub copyDATA()
 
  With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        .Show
        
        fullpath = .SelectedItems.Item(1)
    End With
    
    If InStr(fullpath, ".xls") = 0 Then
        Exit Sub
    End If

Worksheets("Daily").Range("A1:Q2000").Copy

Workbooks.Open Filename:= _
fullpath
    
ActiveSheet.Paste Destination:=Worksheets("Daily").Range("A1")

End Sub

我有一个以前的日期工作簿，其中包含所有格式、评论和其他内容。 新工作簿在没有格式化或任何内容的情况下生成，但在单元格中更新了数据。 我需要做的是将以前的工作簿复制或合并到新生成的工作簿中，它会携带所有内容，包括格式化，但将新数据单独留在新工作簿中。

Answer 1

假设您要比较的列在两个工作簿中都是“B”和“C”

Option Explicit

Sub copyDATA()
   
    Const SHT_NAME = "Daily"
    Const COL_KEY1 = "B"
    Const COL_KEY2 = "C"

    Dim wbA As Workbook, wsA As Worksheet
    Dim wbB As Workbook, wsB As Worksheet, row As Range
    Dim iLastrowA As Long, iLastrowB As Long, iRow As Long
    Dim FileName As String, count(2) As Long

    ' choose workbook A
    Dim fullpath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        If .Show = False Then Exit Sub
        FileName = .SelectedItems.Item(1)
    End With
    
    ' check is xls
    If InStr(FileName, ".xls") = 0 Then
        Exit Sub
    End If
   
    ' workbook B is this workbook
    Set wbB = ThisWorkbook
    Set wsB = wbB.Sheets(SHT_NAME)

    ' build dict of existing key numbers
    Dim dict As Object, key
    Set dict = CreateObject("Scripting.Dictionary")
    iLastrowB = wsB.Cells(Rows.count, COL_KEY1).End(xlUp).row
    For iRow = 1 To iLastrowB
        key = Trim(wsB.Cells(iRow, COL_KEY1)) & _
              Trim(wsB.Cells(iRow, COL_KEY2))
        If dict.exists(key) Then
            MsgBox "Dupicate key " & key & " at row " & iRow, vbCritical
            Exit Sub
        ElseIf Left(key, 7) Like "#######" Then ' 7 digit number
            dict(key) = iRow
        End If
    Next

    ' source data
    Application.ScreenUpdating = False
    Set wbA = Workbooks.Open(FileName, True, True)
    Set wsA = wbA.Sheets(1)
    iLastrowA = wsA.Cells(Rows.count, COL_KEY1).End(xlUp).row
    For iRow = 1 To iLastrowA
        key = Trim(wsA.Cells(iRow, COL_KEY1)) & _
              Trim(wsA.Cells(iRow, COL_KEY2))
        Set row = wsA.Cells(iRow, 1).Resize(1, 17) 'A to Q
        If dict.exists(key) Then
            ' update values only
            row.Copy
            wsB.Cells(dict(key), 1).PasteSpecial xlPasteValues
            count(1) = count(1) + 1
            'highlight updated row - comment out when working
            wsB.Cells(dict(key), 1).Interior.Color = RGB(255, 255, 0)
        
        ElseIf Left(key, 7) Like "#######" Then ' valid 7 digit numbers
            ' add if needed later
            'iLastrowB = iLastrowB + 1
            'row.Copy
            'wsB.Cells(iLastrowB, 1).PasteSpecial xlPasteValues
            'count(2) = count(2) + 1
            'wsB.Cells(iLastrowB, 1).Interior.Color = RGB(0, 255, 0) 'g
        End If
        Application.CutCopyMode = False
    Next
    Application.ScreenUpdating = True
    MsgBox count(1) & " rows updated " & count(2) & " added from " & wbA.Name, vbInformation
    wbA.Close False

End Sub