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列的末尾。然后，您只需选择C列并使用“删除重复项”工具（在“数据”菜单上找到）。

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

Answer 3

我建议单独扫描每一列（也许你在一列中有重复）和如果唯一，则附加到第3列。这可能比您需要的更模块化，但您可以重复使用单个子/函数

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

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可以用更少的代码完成这类事情。以下litte例程将收集任何范围内的所有唯一值（例如您的前两个cols）：

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

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

4 个答案: