excel - 仅当新工作簿中不存在该行时，如何将电子表格中的每一行添加到新工作簿中？

Question

您好，我正在尝试将电子表格中的行复制到新工作簿，但有一些条件。我对 VBA 相当陌生，我希望有人能够帮助我并指导我。谢谢你。

如果该行与新工作簿中可用的任何当前行都不匹配，它只会将该行添加到最底部。

某些列中的某些值会更改(例如，在这种情况下，唯一会更改的列是(年龄、联系人、电子邮件、职业)，但我仍然希望在新工作簿中找到最接近的匹配项并更新它。两个记录可能具有相同的年龄、联系方式、电子邮件、职业组合，但并非所有列都相同。例如，数据 A 与数据 B 具有相同的年龄和职业，但它们的电子邮件和联系方式不同。

更新行后，我希望有一列显示所做的更改。

应用的规则
第一层支票
1. 不会改变的列
姓名年龄
2. 会改变的列。
联系方式、电子邮件、职业
第二层检查
假设两行具有相同的名称，年龄。
然后它将查看联系人、电子邮件、职业等列，然后将其与正确的记录匹配。
联系人、电子邮件、职业中的 3 列中有 2 列可以更改，但 3 列中的至少 1 列将保持不变，并且与其他记录不同。
这是默认的新工作簿。

在从数据到复制表的第一次更新中将一些记录添加到新工作簿中的示例。

这是我将从中复制到新工作簿中的数据。如您所见，列值中的某些字段已更改，但我想与新工作簿中的现有行匹配以找到最接近的匹配项并更新它们。此数据要复制表

这是更新后新工作簿的最终版本，如您所见，它将有一个新列“更改”，其中显示已更改的列。例如，在第一次更新中，联系电话从 1234 更改为 1111。但在第二次更新(此处未显示)中，它将再次更改为 4321，因此我希望更改列有(联系人:1234 -> 1111 -> 4321)。

Answer 1

您在这里面临的第一个问题更多的是概念问题，而不是编程问题。问题是您如何确定 2 行是否匹配。

需要有最少数量的列来匹配或类似的东西。

在您的示例中，您将 2 行与 42 岁的工程师 Alan 匹配，但如果他的职业不同怎么办？那还会是比赛吗？如果是，如果他的年龄改变了怎么办？这足以与新工作簿中的一行匹配吗？如果是，如果像我们这里有两个叫艾伦的人，我们该怎么办？

匹配的候选人可能不止一个。

例如，如果您要复制以下数据怎么办:

您可以看到它将匹配测试数据第一行中的 3/5 列以及第二行测试数据中的 3/5 列。

所以，这是个问题。您需要考虑一个规则来决定在这种情况下应该匹配哪一行。
一旦为匹配两行定义了明确的规则，您就可以开始编写应用这些规则的程序。 (请编辑您的问题以添加这些精度。)
编辑 1:
从您所做的编辑中，仍然存在一个问题:
假设您仍然要复制同一行数据:

您会看到它与第一行中的 Contact 列和第二行中的 Occupation 列匹配。

当只有一列匹配时，我们需要某种优先级来选择。
例如，您可以:
✔ 联系方式 > ✔ 电子邮件 > ✔ 职业
其中“>”表示“优先于”，而“✔”表示我们对该列有一个。
所以，这将是第一步。然后，我们需要确定如果有超过 2 列都匹配，就像在这种情况下一样，这与上面的完全一样，但这次两封电子邮件都匹配，会发生什么:

然后你必须决定是否
✔ 联系方式 + ✔ 电子邮件 > ✔ 职业 + ✔ 电子邮件
有不同的方法可以解决这个问题，但您可以决定您为上面定义的优先级顺序始终成立。基本上，使用 ✔ 联系人 > ✔ 电子邮件 > ✔ 职业这一事实，您可以说已经匹配了联系人，它将是优先行，如果有 2 行匹配联系人，那么我们继续使用电子邮件。这将产生:

✔ 联系方式+ ✔ 电子邮件+ ✔ 职业(不变)

✔联系方式+✔邮箱+❌职业

✔联系方式+❌邮箱+✔职业

✔ 联系方式+❌邮箱+❌职业

❌联系方式 + ✔ 电子邮件 + ✔ 职业

❌联系方式 + ✔ 电子邮件 + ❌职业

❌联系方式 + ❌邮箱 + ✔ 职业

❌联系方式+❌邮箱+❌职业

如果您可以指定此优先级问题，则可以轻松编写此功能。

编辑 2:
既然您已经澄清了某些事情，那么您可以尝试以下方法:
(确保更改工作簿、工作表和范围的名称以满足您的需要)。

Sub TableJoinTest()

    'Those table columns will have to match for the 2 lines to be a match
    Dim MandatoryHeaders() As Variant
    MandatoryHeaders = Array("Name", "Age")
    
    'Other table columns that could be used to decide of a match if there is 2 rows that match the mandatory columns.
    'These headers will be used to determine which row to match to by order of priority
    Dim OtherHeaders() As Variant
    OtherHeaders = Array("Contact", "Email", "Occupation")

    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, _
                OtherHeaders:=OtherHeaders, _
                AddIfMissing:=True, _
                IsLogging:=True
    
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)
 
    '''''''''''''''''''''''''''''''''''''''
    '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 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
                   tArray(MatchRow, tOtherHeadersColumn(k)) = sArray(i, sOtherHeadersColumn(k))
                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

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