如何通过列A中的单个值将列B中的唯一值串联起来

Question

我有两列代表1:多关系。我需要将其缩减为1：1关系，其中列B中的多个项被逗号连接。下面是数据：

zip code neighbors
10001   10010
10001   10011
10001   10016
10001   10018
10001   10119
10001   10199
10003   10012

以下是期望的输出内容：

zip code neighbors
10001   10010, 10011, 10012, 10016, 10018, 10019, 10199

由于有9000条记录，所以需要循环直到记录结束。

现在不确定如何操作。

---

我想通了，感谢大家。以下是代码分享：

Sub Concatenate()

Dim oldValue As String
Dim newValue As String
Dim result As String
Dim counter As Integer

oldValue = ""
newValue = ""
result = ""
counter = 1

For i = 2 To 9401

newValue = Worksheets("data").Cells(i, 1)

If (oldValue <> newValue) Then

    Worksheets("result").Cells(counter, 1).NumberFormat = "@"
    Worksheets("result").Cells(counter, 2).NumberFormat = "@"
    Worksheets("result").Cells(counter, 1) = oldValue
    Worksheets("result").Cells(counter, 2) = result
    counter = counter + 1
    result = ""

End If

If (result = "") Then
    result = Worksheets("data").Cells(i, 2)
Else
    result = result + "," + Worksheets("data").Cells(i, 2)
End If

oldValue = newValue

Next i


End Sub

- user4015

---

抱歉，那个例子不太好，但希望能传达出想法。 - user4015

我可以给你答案，但我希望你先尝试一下。这是一种方法。它是一个VBA方法。 1 使用集合从列表中获取唯一的邮政编码 2 循环遍历唯一的集合，然后在内部循环中，循环遍历Col A。对于每个匹配项，连接值 3 输出到新工作表。 - Siddharth Rout

@SiddharthRout：或者使用字典。我在15000条记录上测试过，速度相当快，只需0.23秒。 - WGS

@BK201：Collection/Dict/Array 更快 :) - Siddharth Rout

我几周前回答过类似的问题。你应该在这里[链接]（https://dev59.com/ennZa4cB1Zd3GeqPsJll）看一下。实际上，你只需要那个示例中的A列和C列。 - Takedasama

Answer 1

恭喜你找到了答案。这里有一个单独的任务，可以在不到一秒钟内处理15,000条记录（当然，机器性能可能会有所不同）。

我的数据：

代码：

Option Explicit
Sub GetByDictionary()
    Dim wBk As Workbook: Set wBk = ThisWorkbook
    Dim wSht As Worksheet: Set wSht = wBk.Sheets("Sheet5") 'Modify accordingly.
    Dim oDict As Object: Set oDict = CreateObject("Scripting.Dictionary")
    Dim lLastRow As Long: lLastRow = wSht.Cells(Rows.Count, 1).End(xlUp).row
    Dim rZIP As Range: Set rZIP = wSht.Range("A2:A" & lLastRow)
    Dim rNeigh As Variant, rCl As Range, rNewZIP As Range, rCl2 As Range
    Dim Start As Variant

    Start = Timer()
    'Store zipcodes and neighbors into dictionary.
    With oDict
        For Each rCl In rZIP
            rNeigh = rCl.Offset(, 1).Value
            If Not .Exists(rCl.Value) And Not IsEmpty(rCl.Value) Then
                .Add rCl.Value, rNeigh
            Else
                .Item(rCl.Value) = .Item(rCl.Value) & ", " & rNeigh
            End If
        Next rCl
    End With

    'Output them somewhere.
    With wSht
        .Range("E1").Value = "zipcode"
        .Range("F1").Value = "neighbors"
        Set rNewZIP = .Range("E2").Resize(oDict.Count)
        rNewZIP.Value = Application.Transpose(oDict.Keys)
        For Each rCl2 In rNewZIP
            rCl2.Offset(0, 1).Value = oDict.Item(rCl2.Value)
        Next rCl2
    End With
    Debug.Print Timer() - Start

End Sub

结果如下：

执行结果：

共用0.31秒执行。

- WGS

Answer 2

以下是我的回答。这是基于之前发布的一个答案这里。

Sub Test_User4015()
Dim MySheet As Worksheet: Set MySheet = Sheets("Sheet1")

'Clear the previous results before populating
MySheet.Range("F:G").Clear

'Step1 Find distinct values on column A and copy them on F
    For i = 1 To Application.WorksheetFunction.CountA(MySheet.Range("A:A"))
    Row_PasteCount = Application.WorksheetFunction.CountA(MySheet.Range("F:F")) + 1
    Set LookupID = MySheet.Range("A" & i)
    Set LookupID_SearchRange = MySheet.Range("F:F")
    Set CopyValueID_Paste = MySheet.Range("F" & Row_PasteCount)
        If IsError(Application.Match(LookupID, LookupID_SearchRange, 0)) Then
            LookupID.Copy
            CopyValueID_Paste.PasteSpecial xlPasteValues
        End If
    Next i

'Step2 fill your values in column(s) G based on selection
    For j = 1 To Application.WorksheetFunction.CountA(MySheet.Range("F:F"))
    Set ID = MySheet.Range("F" & j)
    Set Neighbor = MySheet.Range("G" & j)
For k = 1 To Application.WorksheetFunction.CountA(MySheet.Range("A:A"))
    Set SearchedID = MySheet.Range("A" & k)
    Set SearchedID_Neighbor = MySheet.Range("B" & k)
        If ID.Value = SearchedID.Value Then
            Neighbor.Value = Neighbor.Value & "," & SearchedID_Neighbor.Value
        End If
    Next k
Next j
End Sub

注意！代码已经测试并且可行。希望这可以帮助你。

编辑：我刚才看到您需要处理大约10k行的应用程序。虽然这是可行的，但对于这么大范围的表格来说速度非常慢。最好使用其他方法处理更大的表格。

- Takedasama