Concatenate Account Numbers for list of names (2 columns)

[bjcf33183]

Hi,

I'm *attempting" to take a spreadsheet containing 2 columns, and concatenate the values in Column B ("Account Number") for each unique name in Column A ("User ID"). The resulting concatenated string would go into Column B. Any ideas on the best way to approach this through VBA?

Current Data Example:

UserID Account Number
jsmith 11
jsmith 12
jsmith 13
jsmith 26
bjones 11
bjones 56
bjones 63
bjones 64
jsmith 45
alee 14
alee 66
alee 63
jsmith 87
bjones 95

Desired Result:

UserID Account Number
jsmith 11,12,13,26,45,87
bjones 11,56,63,64,95
alee 14,66,63

 

[Ken Cowen]

This should get you started. You should probably come up with a better/more robust way to identify the input and output. This outputs 3 rows below the end of the data. I also assumed that you don't have anything on the spreadsheet below your the end of your two data columns.

Sub test()


Dim user_accts As New Collection
Dim i As Integer, n As Integer, j As Integer


n = ActiveSheet.UsedRange.Rows.Count


'make a collection of name


For i = 2 To n
    On Error Resume Next
    user_accts.Add Cells(i, 1), Cells(i, 1)
Next i


'output the name list


For i = 1 To user_accts.Count
    Cells(n + 3 + i, 1).Value = user_accts(i)
Next i


'concatenate the numbers to the names


For i = 2 To n
    For j = 1 To user_accts.Count
        If Cells(i, 1) = user_accts(j) Then
            Cells(n + 3 + j, 1).Value = Cells(n + 3 + j, 1).Value & ", " & Cells(i, 2).Value
        End If
    Next j
Next i


End Sub

I hope this helps.

Ken

 

[JoeMo]

Welcome to the board! This assumes your UserID header is in A1. It clears and uses columns D & E for temporary use. If that's a problem the code can be changed to use two empty, isolated columns of your choice.

Sub ConcatIDAndNumber()
'assumes UserID header in A1, Account Numbers in col B
Dim R As Range, V As Variant, IDs As Variant, Nums As String, i As Long, j As Long
Set R = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
V = R.Value
Application.ScreenUpdating = False
Columns("D:E").ClearContents
R.Columns(1).AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("D1"), unique:=True
Range("E1").Value = Range("B1").Value
IDs = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row).Value
For i = 1 To UBound(IDs, 1)
    For j = LBound(V, 1) + 1 To UBound(V, 1)
        If V(j, 1) = IDs(i, 1) Then
            Nums = Nums & ", " & V(j, 2)
        End If
    Next j
    Range("E" & i + 1).Value = Mid(Nums, 3, Len(Nums))
    Nums = ""
Next i
Range("A:B").ClearContents
Range("D1").CurrentRegion.Cut Destination:=Range("A1")
Columns("A:B").AutoFit
Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

Here is one more macro that you can consider...

[table="width: 500"]
[tr]
	[td]Sub UserIDs()
  Dim X As Long, Data As Variant
  Data = Range("A2", Cells(Rows.Count, "B").End(xlUp))
  Columns("C:D").Clear
  Range("C1:D1").Value = Range("A1:B1").Value
  With CreateObject("Scripting.Dictionary")
    For X = 1 To UBound(Data)
      .Item(Data(X, 1)) = .Item(Data(X, 1)) & ", " & Data(X, 2)
      If Left(.Item(Data(X, 1)), 1) = "," Then .Item(Data(X, 1)) = Mid(.Item(Data(X, 1)), 3)
    Next
    Range("C2").Resize(.Count) = Application.Transpose(.Keys)
    Range("D2").Resize(.Count) = Application.Transpose(.Items)
  End With
End Sub[/td]
[/tr]
[/table]

 

[bjcf33183]

Thank you!!! This worked perfectly

Welcome to the board! This assumes your UserID header is in A1. It clears and uses columns D & E for temporary use. If that's a problem the code can be changed to use two empty, isolated columns of your choice.

Sub ConcatIDAndNumber()
'assumes UserID header in A1, Account Numbers in col B
Dim R As Range, V As Variant, IDs As Variant, Nums As String, i As Long, j As Long
Set R = Range("A1:B" & Cells(Rows.Count, "A").End(xlUp).Row)
V = R.Value
Application.ScreenUpdating = False
Columns("D:E").ClearContents
R.Columns(1).AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("D1"), unique:=True
Range("E1").Value = Range("B1").Value
IDs = Range("D2:D" & Cells(Rows.Count, "D").End(xlUp).Row).Value
For i = 1 To UBound(IDs, 1)
    For j = LBound(V, 1) + 1 To UBound(V, 1)
        If V(j, 1) = IDs(i, 1) Then
            Nums = Nums & ", " & V(j, 2)
        End If
    Next j
    Range("E" & i + 1).Value = Mid(Nums, 3, Len(Nums))
    Nums = ""
Next i
Range("A:B").ClearContents
Range("D1").CurrentRegion.Cut Destination:=Range("A1")
Columns("A:B").AutoFit
Application.ScreenUpdating = True
End Sub

 

[JoeMo]

Thank you!!! This worked perfectly

You are welcome - thanks for the reply.

 

[Rick Rothstein]

Here is one more macro that you can consider...

[table="width: 500"]
[tr]
	[td]Sub UserIDs()
  Dim X As Long, Data As Variant
  Data = Range("A2", Cells(Rows.Count, "B").End(xlUp))
  Columns("C:D").Clear
  Range("C1:D1").Value = Range("A1:B1").Value
  With CreateObject("Scripting.Dictionary")
    For X = 1 To UBound(Data)
      .Item(Data(X, 1)) = .Item(Data(X, 1)) & ", " & Data(X, 2)
      If Left(.Item(Data(X, 1)), 1) = "," Then .Item(Data(X, 1)) = Mid(.Item(Data(X, 1)), 3)
    Next
    Range("C2").Resize(.Count) = Application.Transpose(.Keys)
    Range("D2").Resize(.Count) = Application.Transpose(.Items)
  End With
End Sub[/td]
[/tr]
[/table]

I know you have a solution you are happy with, but I wanted to correct the record. The above code that I posted earlier may have a problem if you have a large amount of data. While I could not trace down the amount, it seems the Transpose function has another limitation (total amount of text per array element perhaps) besides the 65535 rows limitation that I am already aware of. The following revised code will work without any problems. I tested it on 2500 rows of data containing 20 unique User IDs and while it is about twice as fast as the code JoeMo posted, that time difference is completely negligible as JoeMo's code only took 0.05 seconds to complete the task, so you can confidently keep using his code (as I said, I am only posting my code to correct the record for future readers of this thread).

[table="width: 500"]
[tr]
	[td]Sub UserIDs()
  Dim X As Long, Z As Long, K As Variant, Data As Variant
  Data = Range("A2", Cells(Rows.Count, "B").End(xlUp))
  With CreateObject("Scripting.Dictionary")
    For X = 1 To UBound(Data)
      .Item(Data(X, 1)) = .Item(Data(X, 1)) & ", " & Data(X, 2)
      If Left(.Item(Data(X, 1)), 2) = ", " Then .Item(Data(X, 1)) = Mid(.Item(Data(X, 1)), 3)
    Next
    Application.ScreenUpdating = False
    Columns("C:D").Clear
    Range("C1:D1").Value = Range("A1:B1").Value
    For Each K In .Keys
      Z = Z + 1
      Cells(Z + 1, "C").Value = K
      Cells(Z + 1, "D").Value = .Item(K)
    Next
    Application.ScreenUpdating = True
  End With
End Sub[/td]
[/tr]
[/table]