Excel VBA实现提取工作簿到主工作簿的数据合并与更新需求

需求说明 #

拥有两个Excel工作簿：主副本（MC）和数据提取源（EXTRACT）。MC中已有部分数据，需每日从更新后的EXTRACT同步数据，逻辑如下：

• 两行完全匹配（所有字段一致）：忽略该行
• 仅日期字段不同的近似匹配行（其他字段一致）：更新MC中的日期
• 未在MC中出现的新增行：追加到MC的下一个空白行

现有代码及问题 #

本人为VBA新手，编写了以下代码，但对部分逻辑（如相同信息不同日期的行处理）存疑，尝试用数组存储单元格位置校验：

现有代码 #

Public Sub Checker()
    
    Dim iloop As Integer                'Created variable iloop as an integer
    Dim iloop2 As Integer               'Created variable iloop2 as an integer
    Dim lines As Integer                'Created variable lines as an integer
    Dim wb As Workbook                  'Creates variable wb - Source, or Book1
    Dim MC As Workbook                  'Creates variable MC - Master Copy
    Dim celltxt As String               'Creates string variable
    Dim celltx As String                'Creates string variable
    Dim copied(1 To 1) As Range         'Creates an array with range type variables

    Set lines = 1
    Set MC = Workbooks("Master Final SOs Testing")      'Sets the MC cariable to Master Final SOs Testing
    Set wb = Workbooks("Book1 (3)")     'Sets the wb variable to Book1 (3)
    Set iloop = 2                       'Var for Book1
    Set iloop2 = 2                      'Var for MC
    'if we get workbook instance then
    If Not wb Is Nothing Then           'If wb actually has something, then...
        While wb.Cells(iloop, 2) <> ""                                  'As long as (iloop, 2) in Book is not empty, then
            While MC.Cells(iloop2, 2) <> ""                             'As long as (iloop2, 2) in MC is not empty, then
                If wb.Cells(iloop, 2) <> MC.Cells(iloop2, 2) Then       'If the SOs do not match then
                    iloop2 = iloop2 + 1                                 'Add to iloop2 in MC to move to next row
                Else
                    If MC.Cells(iloop2, 2) <> copied() Then
                        wb.Activate                                         'Else, activate the Scheduled Ship date cell, select it, copy it, then paste it in the right cell in MC
                        wb.Cells(iloop, 4).Select
                        wb.Cells(iloop, 4).Copy
                        MC.Cells(iloop2, 4).PasteSpecial
                        wb.Cells(iloop, 1).Select                          'Selects the first header
                        celltxt = wb.Selection.Text                        'sets the variable to equal the selected cell text
                        MC.Cells(iloop2, 1).Select                         'Selects the first header
                        celltx = MC.Selection.Text                         'sets the variable to equal the selected cell text
                        copied(lines) = MC.Cells(iloop2, 2)                'Adds the current cell range that was just copied to the array in the newest open slot
                        lines = lines + 1                                  'Adds 1 to lines for next time a range needs to be added to the array
                        ReDim Preserve copied(1 To UBound(copied) + 1) As Range     'Adds a new slot to the array while keeping/preserving the data already in it
                        
                        If wb.InStr(1, celltxt, "Y") > 0 And MC.InStr(1, celltx, "R") > 0 Then          'If the line is Y Packaged, and it was in the rack, change it to be in the basket
                            MC.Cells(1, iloop2).Value = B
                        End If
                    End If
                    iloop2 = iloop2 + 1
                End If
            Wend
            iloop = iloop + 1                                           'Add 1 to iloop to move to next SO in Book
            iloop2 = 2                                                  'Reset iloop2 to 2 to restart the process
        Wend
    End If


End Sub

代码存在的问题 #

1. 变量赋值错误：Integer类型变量（lines、iloop等）不能用Set赋值，直接用lines = 1即可
2. 数组逻辑错误：copied()空引用、存储Range对象效率低，不如直接存储订单号
3. 匹配逻辑不完整：仅通过订单号（列2）判断，未验证除日期外的其他字段是否一致
4. 操作效率低下：频繁使用Activate、Select，应直接操作单元格值
5. 语法错误：MC.Cells(1, iloop2).Value = B中B未定义，应为字符串"B"
6. 缺少新增行逻辑：未处理EXTRACT中未在MC找到的行，无法实现追加功能

解决方案（含伪代码） #

伪代码 #

1. 定义MC和EXTRACT工作簿、工作表对象
2. 获取EXTRACT数据的最后一行，获取MC数据的最后一行
3. 遍历EXTRACT的每一行（从第2行开始）：
   a. 提取当前行的订单号（唯一标识）、除日期外的所有字段内容
   b. 在MC的订单号列查找是否存在相同订单号：
      i. 找到匹配行：
         - 对比当前行与MC匹配行的除日期外所有字段
         - 若字段完全一致但日期不同：更新MC该行的日期
         - 若字段不一致：可忽略或标记（按需处理）
      ii. 未找到匹配行：
         - 将当前行复制到MC的下一个空白行
4. 保存MC工作簿，释放对象

修正后的VBA代码 #

Public Sub SyncMasterData()
    Dim wbExtract As Workbook
    Dim wbMaster As Workbook
    Dim wsExtract As Worksheet
    Dim wsMaster As Worksheet
    Dim lastRowExtract As Long
    Dim lastRowMaster As Long
    Dim i As Long
    Dim matchRow As Range
    Dim isFullMatch As Boolean
    
    ' 定义工作簿和工作表（请根据实际名称修改）
    Set wbExtract = Workbooks("Book1 (3)")
    Set wbMaster = Workbooks("Master Final SOs Testing")
    Set wsExtract = wbExtract.Worksheets(1) ' 默认第一个工作表，可修改为表名
    Set wsMaster = wbMaster.Worksheets(1)
    
    ' 获取数据最后一行
    lastRowExtract = wsExtract.Cells(wsExtract.Rows.Count, 2).End(xlUp).Row
    lastRowMaster = wsMaster.Cells(wsMaster.Rows.Count, 2).End(xlUp).Row
    
    ' 遍历EXTRACT的每一行数据（从第2行开始，跳过表头）
    For i = 2 To lastRowExtract
        ' 在Master的订单号列（第2列）查找当前订单号
        Set matchRow = wsMaster.Columns(2).Find(What:=wsExtract.Cells(i, 2).Value, _
                                               LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not matchRow Is Nothing Then
            ' 找到匹配行，检查除日期外的字段是否一致（假设日期在第4列）
            isFullMatch = True
            ' 遍历所有列，跳过日期列4，可根据实际列数调整
            Dim col As Integer
            For col = 1 To wsExtract.Cells(1, wsExtract.Columns.Count).End(xlToLeft).Column
                If col <> 4 Then ' 跳过日期列
                    If wsExtract.Cells(i, col).Value <> wsMaster.Cells(matchRow.Row, col).Value Then
                        isFullMatch = False
                        Exit For
                    End If
                End If
            Next col
            
            ' 仅日期不同，更新Master的日期
            If isFullMatch And wsExtract.Cells(i, 4).Value <> wsMaster.Cells(matchRow.Row, 4).Value Then
                wsMaster.Cells(matchRow.Row, 4).Value = wsExtract.Cells(i, 4).Value
            End If
            
            ' 额外逻辑：状态从R改为B（原代码需求）
            If wsExtract.Cells(i, 1).Value Like "*Y*" And wsMaster.Cells(matchRow.Row, 1).Value Like "*R*" Then
                wsMaster.Cells(matchRow.Row, 1).Value = "B"
            End If
        Else
            ' 未找到匹配行，追加到Master末尾
            lastRowMaster = lastRowMaster + 1
            ' 复制整行数据（可指定列范围，比如1到5）
            wsExtract.Rows(i).Copy Destination:=wsMaster.Rows(lastRowMaster)
        End If
    Next i
    
    ' 保存Master工作簿
    wbMaster.Save
    
    ' 释放对象
    Set wsExtract = Nothing
    Set wsMaster = Nothing
    Set wbExtract = Nothing
    Set wbMaster = Nothing
    
    MsgBox "数据同步完成！"
End Sub

代码说明 #

• 避免了Activate/Select操作，直接通过工作表对象操作单元格，提升效率
• 使用Find方法快速查找匹配订单号，比逐行遍历更高效
• 增加了除日期外的字段对比，确保仅更新日期不同的近似匹配行
• 实现了新增行的追加逻辑
• 保留了原代码中状态从R改为B的需求，修正了语法错误

内容的提问来源于stack exchange，提问作者Phantom12203