Excel VBA如果第一列中的值相同，则在另一列中连接值

Question

我的问题是，如果B列中的数据相同，我想在C列中连接数据。例如：

Column B     |     Column C
IXX          |     AI
IXX          |     BI
IYY          |     CI
IZZ          |     GI
IYY          |     TI

输出应该是：

Column D     
IXX (AI-BI)
IXX (AI-BI)
IYY (CI-TI)        
IZZ (GI)
IYY (CI-TI)

但我不知道从哪里开始，使用vba。我的想法是循环遍历行并使用列B连接所有相同的数据。

谢谢。

Answer 1

干得好。 XlFindAll函数不是为此目的而自定义编写的，只是自定义的。因此它包含一些多余的代码。

Sub TestFindAll()
    ' 23 Dec 2017

    Dim Ws As Worksheet
    Dim Rng As Range                            ' range to search in
    Dim Matches As String
    Dim R As Long, Rl As Long

    Set Ws = ActiveSheet
    Application.ScreenUpdating = False
    With Ws
        Rl = .Cells(.Rows.Count, "B").End(xlUp).Row
        ' search items are in column B, starting in row 2
        Set Rng = Range(.Cells(2, "B"), .Cells(Rl, "B"))
        ' matches will be returned form the adjacent column
        ' however this can be adjusted in the XlFindAll function
        For R = 2 To Rl
            Matches = XlFindAll(Rng, .Cells(R, "B").Value)
            If Len(Matches) Then
                ' output to column D
                .Cells(R, "D").Value = .Cells(R, "B").Value & " (" & Matches & ")"
            End If
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Function XlFindAll(Where As Range, _
                   ByVal What As Variant, _
                   Optional ByVal LookIn As Variant = xlValues, _
                   Optional ByVal LookAt As Long = xlWhole, _
                   Optional ByVal SearchBy As Long = xlByColumns, _
                   Optional ByVal StartAfter As Long, _
                   Optional ByVal Direction As Long = xlNext, _
                   Optional ByVal MatchCase As Boolean = False, _
                   Optional ByVal MatchByte As Boolean = False, _
                   Optional ByVal After As Range, _
                   Optional ByVal FindFormat As Boolean = False) As String
    ' 23 Dec 2017
    ' Settings LookIn, LookAt, SearchOrder, and MatchByte
    ' are saved each time the Find method is used

    Dim Fun() As String
    Dim Search As Range
    Dim Fnd As Range
    Dim FirstFnd As String
    Dim i As Long

    Set Search = Where
    With Search
        If After Is Nothing Then
            If StartAfter Then
                StartAfter = WorksheetFunction.Min(StartAfter, .Cells.Count)
            Else
                StartAfter = .Cells.Count
            End If
            Set After = .Cells(StartAfter)
        End If

        Set Fnd = .Find(What:=What, After:=After, _
                        LookIn:=LookIn, LookAt:=LookAt, _
                        SearchOrder:=SearchBy, SearchDirection:=Direction, _
                        MatchCase:=MatchCase, MatchByte:=MatchByte, _
                        SearchFormat:=FindFormat)
        If Not Fnd Is Nothing Then
            FirstFnd = Fnd.Address
            ReDim Fun(100)
            Do
                ' select the value in the adjacent cell on the same row
                Fun(i) = Fnd.Offset(0, 1).Value
                i = i + 1
                Set Fnd = .FindNext(Fnd)
            Loop While Not (Fnd Is Nothing) And (Fnd.Address <> FirstFnd)
        End If
    End With

    If i Then ReDim Preserve Fun(i - 1)
    XlFindAll = Join(Fun, "-")
End Function

Answer 2

您可以使用此用户定义函数来获得所需的输出。

Function CustomConcatenate(ByVal Rng As Range, ByVal Lookup As String) As String
Dim str As String
Dim cell As Range
For Each cell In Rng.Columns(1).Cells
    If cell = Lookup Then
        If str = "" Then
            str = cell.Offset(0, 1).Value
        Else
            str = str & "-" & cell.Offset(0, 1).Value
        End If
    End If
Next cell
CustomConcatenate = str
End Function

然后在下面的表格上使用此UDF ...

假设您的样本数据在B2：C6范围内，请尝试此...

在D2

=CustomConcatenate($B$2:$C$6,B2)

Answer 3

您还可以使用如下所示的Dictionary对象来获得所需的结果。

Public Sub ConcatOutput()
Dim rg As Range
Dim strOut As String
Dim Key
Application.ScreenUpdating = False
With CreateObject("Scripting.Dictionary")
    '\\ First Pass - Built List
    .CompareMode = vbTextCompare
    For Each rg In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
        If .Exists(rg.Value) Then
            .Item(rg.Value) = .Item(rg.Value) & "-" & rg.Offset(0, 1).Value
        Else
            .Add rg.Value, " (" & rg.Offset(0, 1).Value
        End If
    Next
    '\\ Second Pass - Output to range of cells
    For Each rg In Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
        rg.Offset(0, 2).Value = rg.Value & .Item(rg.Value) & ")"
    Next
End With
Application.ScreenUpdating = True
End Sub