如何通过A列中的奇异值连接B列中的唯一值

Question

我有两列代表1：很多关系。我需要将其降低到1：1的关系，其中列B中的许多用逗号连接。数据如下：

zipcode neighbors
10001   10010
10001   10011
10001   10016
10001   10018
10001   10119
10001   10199
10003   10012

这就是我希望输出看起来像：

zipcode 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

Answer 1

Bravo搞清楚。这是一个单独的任务，可以在不到一秒的时间内处理15,000条记录（当然是机器方面的YMMV）。

我的数据：

代码：

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秒。

Answer 2

这是我对您的查询的看法。这是基于之前发布的here

回答

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行。这是有效的，但在这样的范围内非常慢。对于更大的桌子，更好地坚持其他东西。