如何在列B中以列A中的奇异值连接唯一值

我有两列代表1：多关系。 我需要把它降低到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个logging，所以我需要运行一个循环，直到logging结束。

现在确定如何做到这一点。

---

我明白了，谢谢大家。 代码分享如下：

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条logging（当然，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 

注意！ 该守则经过testing和工作。 希望这可以帮助，

编辑我刚刚读过你需要这个来覆盖应用程序10K行。 这是工作，但在这样的范围非常缓慢。 更好地坚持别的更大的桌子。