如何通过A列中的奇异值连接B列中的唯一值 [英] How to concatenate unique values in column B by singular values in column A

问题描述

我有两列代表一对多的关系.我需要将这种关系简化为1:1的关系，其中B列中的许多元素以逗号连接.数据如下:

I have two columns representing a 1:many relationship. I need to reduce this down to a 1:1 relationship where the many in columnn B are concatenated by commas. Data below:

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

这是我想要的输出看起来像什么:

Here is what I want the output to look like:

zipcode neighbors
10001   10010, 10011, 10012, 10016, 10018, 10019, 10199

有9000条记录，因此我需要循环运行直到记录结束.

There are 9000 records so I need to run a loop until end of record.

现在确定该怎么做.

我想通了，谢谢大家.代码共享如下:

I figured it out, thanks everyone. Code share below:

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

推荐答案

Bravo解决了这个问题.这是一项单独的任务，可以在不到一秒钟的时间内处理15,000条记录(当然是YMMV机器方式).

Bravo for figuring it out. Here's a separate task that can process 15,000 records in less than a second (YMMV machine-wise, of course).

我的数据:

代码:

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

这篇关于如何通过A列中的奇异值连接B列中的唯一值的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！