即使您的问题是关于在 VBA 中执行此操作，我只想提一下，您尝试执行的操作似乎也可以使用 Power Query 完成。
话虽如此，如果您要为此使用 VBA，则必须使用 Match 函数来查找行匹配的位置，然后将数据从源表复制到目标表。
我已经修改了我提供给this question 的代码，以更好地满足您的特定需求。我所做的其中一件事是添加一个名为 DoOverwrite 的可选参数并将其设置为 false。这将确保某一行中的信息在以后不会被另一行覆盖。
Sub TableJoinTest()
'Those table columns will have to match for the 2 lines to be a match
Dim MandatoryHeaders() As Variant
MandatoryHeaders = Array("Account Number")
Dim SourceTableAnchor As Range
Set SourceTableAnchor = Workbooks("SourceWorkbook.xlsx").Sheets("Sheet1").Range("A1")
Dim TargetTableAnchor As Range
Set TargetTableAnchor = Workbooks("TargetWorkbook.xlsx").Sheets("Sheet1").Range("A1")
TableJoin _
SourceTableAnchor:=SourceTableAnchor, _
TargetTableAnchor:=TargetTableAnchor, _
MandatoryHeaders:=MandatoryHeaders, _
AddIfMissing:=False, _
IsLogging:=False, _
DoOverwrite:=False
End Sub
Sub TableJoin( _
SourceTableAnchor As Range, _
TargetTableAnchor As Range, _
MandatoryHeaders As Variant, _
Optional OtherHeaders As Variant, _
Optional AddIfMissing As Boolean = False, _
Optional IsLogging As Boolean = False, _
Optional DoOverwrite As Boolean = True)
'''''''''''''''''''''''''''''''''''''''
'Definitions
'''''''''''''''''''''''''''''''''''''''
Dim srng As Range, trng As Range
Set srng = SourceTableAnchor.CurrentRegion
Set trng = TargetTableAnchor.CurrentRegion
Dim sHeaders As Range, tHeaders As Range
Set sHeaders = srng.Rows(1)
Set tHeaders = trng.Rows(1)
'Store in Arrays
Dim sArray() As Variant 'prefix s is for Source
sArray = ExcludeRows(srng, 1).Value2
Dim tArray() As Variant 'prefix t is for Target
tArray = ExcludeRows(trng, 1).Value2
Dim sArrayHeader As Variant
sArrayHeader = sHeaders.Value2
Dim tArrayHeader As Variant
tArrayHeader = tHeaders.Value2
'Find Column correspondance
Dim sMandatoryHeadersColumn As Variant
ReDim sMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim tMandatoryHeadersColumn As Variant
ReDim tMandatoryHeadersColumn(LBound(MandatoryHeaders) To UBound(MandatoryHeaders))
Dim k As Long
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), sArrayHeader, 0)
tMandatoryHeadersColumn(k) = Application.Match(MandatoryHeaders(k), tArrayHeader, 0)
Next k
Dim sOtherHeadersColumn As Variant
ReDim sOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
Dim tOtherHeadersColumn As Variant
ReDim tOtherHeadersColumn(LBound(OtherHeaders) To UBound(OtherHeaders))
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
sOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), sArrayHeader, 0)
tOtherHeadersColumn(k) = Application.Match(OtherHeaders(k), tArrayHeader, 0)
Next k
'Merge mandatory headers into one column (aka the helper column method)
Dim i As Long, j As Long
Dim sHelperColumn() As Variant
ReDim sHelperColumn(LBound(sArray, 1) To UBound(sArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
sHelperColumn(i, 1) = sHelperColumn(i, 1) & sArray(i, sMandatoryHeadersColumn(j))
Next j
Next i
Dim tHelperColumn() As Variant
ReDim tHelperColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(tArray, 1) To UBound(tArray, 1)
For j = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
tHelperColumn(i, 1) = tHelperColumn(i, 1) & tArray(i, tMandatoryHeadersColumn(j))
Next j
Next i
'Find all matches
Dim MatchList() As Variant
Dim LoggingColumn() As String
ReDim LoggingColumn(LBound(tArray, 1) To UBound(tArray, 1), 1 To 1)
For i = LBound(sArray, 1) To UBound(sArray, 1)
ReDim MatchList(LBound(tArray, 1) To UBound(tArray, 1))
For j = LBound(tArray, 1) To UBound(tArray, 1)
If sHelperColumn(i, 1) = tHelperColumn(j, 1) Then
MatchList(j) = 1
End If
Next j
'Get the row number for the match
Dim MatchRow As Long
Select Case Application.Sum(MatchList)
Case Is > 1
'Need to do more matching
Dim MatchingScoresList() As Long
ReDim MatchingScoresList(1 To UBound(tArray, 1))
Dim m As Long
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
For m = LBound(tArray, 1) To UBound(tArray, 1)
If tArray(m, sOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k)) Then
MatchingScoresList(m) = MatchingScoresList(m) + 2 ^ (UBound(OtherHeaders) - k)
End If
Next m
Next k
'Get the max score position
Dim MyMax As Long
MyMax = Application.Max(MatchingScoresList)
If Application.Count(Application.Match(MatchingScoresList(), Array(MyMax), 0)) > 1 Then
MsgBox "Error: can't determine how to match row " & i & " in source table"
Exit Sub
Else
MatchRow = Application.Match(MyMax, MatchingScoresList, 0)
End If
Case Is = 1
MatchRow = Application.Match(1, MatchList, 0)
Case Else
Dim nArray() As Variant, Counter As Long
If AddIfMissing Then
MatchRow = 0
Counter = Counter + 1
ReDim nArray(1 To Counter, 1 To UBound(tArray, 2))
For k = LBound(MandatoryHeaders) To UBound(MandatoryHeaders)
nArray(Counter, tMandatoryHeadersColumn(k)) = sArray(i, sMandatoryHeadersColumn(k))
Next k
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
nArray(Counter, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
Next k
Else
MsgBox "Error: Couldn't find a match for data row #" & i
Exit Sub
End If
End Select
'Logging and assigning values
If MatchRow > 0 Then
For k = LBound(OtherHeaders) To UBound(OtherHeaders)
If tArray(MatchRow, tOtherHeadersColumn(k)) <> sArray(i, sOtherHeadersColumn(k)) Then
'Logging
If IsLogging And DoOverwrite Then LoggingColumn(MatchRow, 1) = LoggingColumn(MatchRow, 1) & _
IIf(LoggingColumn(MatchRow, 1) <> "", ", ", "") & _
tHeaders.Cells(1, tOtherHeadersColumn(k)) & " : " & _
tArray(MatchRow, tOtherHeadersColumn(k)) & _
" -> " & sArray(i, sOtherHeadersColumn(k))
'Assign new value
If DoOverwrite Or tArray(MatchRow, tOtherHeadersColumn(k)) = VbNullString Then
tArray(MatchRow, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
End If
End If
Next k
End If
Next i
'Write arrays to sheet
ExcludeRows(trng, 1).Value2 = tArray
With trng.Parent
If IsArrayInitialised(nArray) And AddIfMissing Then
.Cells(trng.Cells(1, 1).Row + trng.Rows.Count, trng.Cells(1, 1).Column).Resize(UBound(nArray, 1), UBound(nArray, 2)).Value2 = nArray
End If
If IsLogging Then
.Cells(trng.Cells(1, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count) = "Changes"
.Cells(trng.Cells(2, 1).Row, trng.Cells(1, 1).Column + trng.Columns.Count).Resize(UBound(LoggingColumn, 1), 1).Value2 = LoggingColumn
End If
End With
End Sub
并将这些函数添加到您的 VBA 项目中，因为它们在上述过程中使用。
Function IsArrayInitialised(ByRef A() As Variant) As Boolean
On Error Resume Next
IsArrayInitialised = IsNumeric(UBound(A))
On Error GoTo 0
End Function
Function ExcludeRows(MyRng As Range, StartRow As Long, Optional EndRow As Long = -1) As Range
'PURPOSE: Exclude one or more consecutives rows from an existing range
Dim Afterpart As Range, BeforePart As Range
If StartRow < 1 Or EndRow > MyRng.Rows.Count Then Set ExcludeRows = Nothing
If StartRow = 1 And EndRow = MyRng.Rows.Count Then Set ExcludeRows = Nothing
If EndRow = -1 Then EndRow = StartRow
If EndRow < MyRng.Rows.Count Then
With MyRng.Parent
Set Afterpart = .Range(MyRng.Cells(EndRow + 1, 1), MyRng.Cells(MyRng.Rows.Count, MyRng.Columns.Count))
End With
End If
If StartRow > 1 Then
With MyRng.Parent
Set BeforePart = .Range(MyRng.Cells(1, MyRng.Cells(1, 1).Column), MyRng.Cells(StartRow - 1, MyRng.Columns.Count))
End With
End If
Set ExcludeRows = Union2(True, BeforePart, Afterpart)
End Function
Public Function Union2(IgnoreEmptyRange As Boolean, ParamArray RangeArray() As Variant) As Range
'PURPOSE: Samae as Application.Union but allows some range object to be Empty
Dim V As Variant
Dim Rng As Range
For Each V In RangeArray
Do
If VarType(V) = vbEmpty Then Exit Do
Set Rng = V
If Not Union2 Is Nothing Then
Set Union2 = Union(Union2, Rng)
ElseIf Not Rng Is Nothing Then
Set Union2 = Rng
End If
Loop While False
Next
End Function