Excel：比较两列（名称列表），在第三列合并

Question

我想比较包含名称列表的两列。 第一栏中的大多数名称也位于第二栏中。 我想创建第三列，将两列合并，并删除重复的名称。

Answer 1

这将起作用。 根据需要定义范围。

Sub combineNames()
    Dim varCol1, varCol2, varCol3
    Dim numDuplicates As Long
    Dim i1 As Integer
    Dim i2 As Integer
    Dim booIsDuplicate As Boolean

    ' Get names from sheet, put in Variant array
    varCol1 = Range("E1:E6")
    varCol2 = Range("F1:F6")

    ReDim varCol3(1 To UBound(varCol1, 1) + UBound(varCol2, 1), 1 To 1)

    ' Insert all names from 1st column
    For i1 = 1 To UBound(varCol1, 1)
        varCol3(i1, 1) = varCol1(i1, 1)
    Next i1

    ' Insert names from 2nd column if not duplicate
    numDuplicates = 0
    For i2 = 1 To UBound(varCol2, 1)
        booIsDuplicate = False
        ' Check if already in 3rd column
        For i1 = 1 To UBound(varCol1, 1)
            If varCol2(i2, 1) = varCol3(i1, 1) Then
                ' It's a duplicate.
                booIsDuplicate = True
                numDuplicates = numDuplicates + 1
                Exit For
            End If
        Next i1
        If booIsDuplicate = False Then
            ' It's not a duplicate; add it to the list.
            varCol3(i2 + UBound(varCol1, 1) - numDuplicates, 1) _
                = varCol2(i2, 1)
        End If
    Next i2

    ' Put combined name list back in sheet.
    Range("G1").Resize( _
        UBound(varCol1, 1) + UBound(varCol2, 1) - numDuplicates, 1) = varCol3

End Sub

Answer 2

如果要避免使用宏，并且工作表中不包含过多的行，则可以简单地从A列复制值并将其粘贴到C列，然后从B列复制值并粘贴到末尾然后，您只需选择C列，然后使用“删除重复项”工具（位于“数据”菜单上）即可。

注意：如果列A或B包含公式，则只想使用PasteSpecial粘贴值。

Answer 3

我建议单独扫描每一列（也许您在一列中有重复项），如果唯一则追加到第三列。 这可能比您需要的模块更多，但是您可以重复使用单个sub /的功能

假设：列中没有空白单元格

Sub Merge()
Dim S1 As Range, S2 As Range, T As Range

    Set S1 = ActiveSheet.[A1]   ' 1st cell of 1st Source column
    Set S2 = ActiveSheet.[B1]   ' 1st cell of 2nd Source column
    Set T = ActiveSheet.[C1]    ' 1st cell of Target range

    ScanCol S1, T
    ScanCol S2, T

End Sub

Sub ScanCol(S As Range, T As Range)
Dim Idx As Long, Jdx As Long

    Idx = 1
    Do While S(Idx, 1) <> ""
        Jdx = GetKey(S(Idx, 1), T)
        If Jdx <> 0 Then
            T(Jdx, 1) = S(Idx, 1)
        End If
        Idx = Idx + 1
    Loop
End Sub

Function GetKey(S As String, T As Range) As Long
Dim Idx As Long, IsFound As Boolean

    GetKey = 0
    IsFound = False
    Idx = 1

    Do While T(Idx, 1) <> ""
        If T(Idx, 1) = S Then
            IsFound = True
            Exit Do
        End If
        Idx = Idx + 1
    Loop

    If Not IsFound Then
        GetKey = Idx            ' return number of first blank line
    End If

End Function

结果

A   A   A
B   C   B
C   E   C
A   F   E
E   G   F
    H   G
        H

Answer 4

使用Collections可以用更少的代码完成这种事情。 以下litt例程将收集任何范围（例如您的第一个两个列）中的所有唯一值：

Private Function UniqueVals(rgArea As Range) As Collection
    Set UniqueVals = New Collection
    Dim rgCell As Range
    For Each rgCell In rgArea.Cells
        On Error Resume Next: Call UniqueVals.Add(rgCell.Value, CStr(rgCell.Value)): On Error GoTo 0
    Next rgCell
End Function  

要查看它的实际效果，这里有一个小测试例程，可对当前在活动工作表上选择的任何单元格进行操作并进行调试。将结果打印到（Ctrl-G）immed窗口中：

Public Sub Test()
    Dim vItem As Variant
    For Each vItem In UniqueVals(Selection)
        Debug.Print vItem
    Next vItem
End Sub