比较两个工作表并使用 ID 号作为键的新数据更新主列表

Question

我在同一个工作簿中有两个工作表。一个是主数据（“玩家目录”），另一个是每周摘要页面（“玩家跟踪”）。

玩家追踪页面将包含更新的信息以及应该添加到玩家目录页面的新玩家。

我想过创建 3 个数组。一个用于播放器跟踪，另一个用于播放器目录，最后一个用于新信息，但我在任何工作和搜索互联网方面都没有成功。

比较这两张表并将缺失的数据添加到玩家目录的最佳方法是什么。两张表都按玩家 ID 列出了玩家，这是一个很好的起点。

使用Player Tracking Page比较和更新的信息如下：

1. 如果在玩家目录中找不到玩家 ID 号，则将此玩家添加到目录中。
2. 如果号码匹配，请比较 C 列和 D 列，并分别更新玩家目录表 C 和 D 列中的玩家姓名和昵称，并更新任何更改。
3. 如果数字匹配，请将玩家跟踪工作表中 G 列中的费用添加到 K 列中的费用数字中，并在列中返回该新数字的结果。

玩家追踪工作表（每周更新）

玩家目录工作表（主）

Sub DirectoryAdds()
    Dim arUpdates() As Variant
    Dim arOriginal() As Variant
    Dim arAdds() As Variant
    Dim wsPD As Worksheet
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Set wsPD = Worksheets("Player Directory")
    
    ReDim Preserve arUpdates(4 To ActiveSheet.Range("B" & Rows.Count).End(xlUp).row)
    ReDim Preserve arOriginal(4 To wsPD.Range("B" & Rows.Count).End(xlUp).row)
    ReDim Preserve arAdds(4 To UBound(arUpdates, 1))
    
    'arUpdates = ActiveSheet.Range("B4", Range("B" & Rows.Count).End(xlUp)).Value
    'arOriginal = wsPD.Range("B4", Range("B" & Rows.Count).End(xlUp)).Value
        For i = LBound(arUpdates) To UBound(arUpdates)
            arUpdates(i) = ActiveSheet.Cells(i, 2)
        Next i
        For j = LBound(arOriginal) To UBound(arOriginal)
            arOriginal(j) = wsPD.Cells(j, 2)
        Next j
    
        For k = LBound(arUpdates) To UBound(arUpdates)
            If IsError(Application.Match(arUpdates(i), arOriginal(j), 0)) Then
                k = k + 1
                arAdds(k, 2) = arUpdates(i, 2)
            End If
        Next k
    
    'Range("K2").Resize(j) = Application.Transpose(v3)
    
End Sub

Answer 1

更新工作表

根据需要调整常量和前两个数组。

Option Explicit

Sub DirectoryAdds()

    Const tgtName As String = "Player Directory"
    Const srcFirstRow As Long = 4
    Const tgtFirstRow As Long = 4

    Dim srcColumns As Variant: srcColumns = Array(2, 3, 4, 7)
    Dim tgtColumns As Variant: tgtColumns = Array(2, 3, 4, 11)

    Dim PT As Worksheet: Set PT = ThisWorkbook.ActiveSheet
    Dim PD As Worksheet: Set PD = ThisWorkbook.Worksheets(tgtName)
    Dim rng As Range
    Dim Source As Variant, Target As Variant
    Dim NewRow As Long
    Dim Curr As Long
    Dim UB As Long
    Dim i As Long
    Dim k As Long

    If PT Is PD Then MsgBox "Wrong sheet selected.": GoTo exitProcedure
    Set rng = PT.Columns(srcColumns(0)).Find("*", , xlFormulas, , , xlPrevious)
    If rng Is Nothing Then GoTo exitProcedure
    If rng.Row < srcFirstRow Then GoTo exitProcedure
    Source = PT.Range(PT.Cells(srcFirstRow, srcColumns(0)), rng)

    Set rng = PD.Columns(tgtColumns(0)).Find("*", , xlFormulas, , , xlPrevious)
    If rng Is Nothing Then GoTo exitProcedure
    If rng.Row < tgtFirstRow Then GoTo exitProcedure
    Target = PD.Range(PD.Cells(tgtFirstRow, tgtColumns(0)), rng)
    NewRow = rng.Row + 1

    UB = UBound(srcColumns)
    For i = 1 To UBound(Source)
        On Error Resume Next
        Curr = WorksheetFunction.Match(Source(i, 1), Target, 0)
        If Err.Number = 0 Then
            On Error GoTo 0
            GoSub updateExistingRecord
        Else
            On Error GoTo 0
            GoSub addNewRecord
        End If
    Next

    MsgBox "Operation finished successfully."

    GoTo exitProcedure

updateExistingRecord:
    Set rng = PD.Cells(Curr + tgtFirstRow - 1, tgtColumns(UB))
    rng.Value = rng.Value + PT.Cells(i + srcFirstRow - 1, srcColumns(UB)).Value
Return

addNewRecord:
    For k = 0 To UB - 1
        PD.Cells(NewRow, tgtColumns(k)).Value = _
          PT.Cells(i + srcFirstRow - 1, srcColumns(k)).Value
    Next k
    Set rng = PD.Cells(NewRow, tgtColumns(UB))
    rng.Value = rng.Value + PT.Cells(i + srcFirstRow - 1, srcColumns(UB)).Value
    NewRow = NewRow + 1
Return

exitProcedure:
End Sub