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

Question

我有两列代表 1:many 关系。我需要将其减少到 1:1 的关系，其中列 B 中的许多由逗号连接。数据如下：

邮政编码邻居 10001 10010 10001 10011 10001 10016 10001 10018 10001 10119 10001 10199 10003 10012

这是我希望输出的样子：

邮政编码邻居 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

为解决这个问题而喝彩。这是一个单独的任务，可以在不到一秒的时间内处理 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 行。这是有效的，但在这样的范围内 非常 很慢。对于更大的桌子，最好坚持使用其他东西。