如何通過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

這是我對您的查詢的看法。 這是基於此處發布的先前答案

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行。 這是有效的，但在這樣的范圍內非常慢。 更好地堅持其他更大的桌子。