Concatenate values VBA

[FryGirl]

Hello All,

I found this macro below to help concatenate values from the first table into the second table. This is a relatively small sample of the original data, and due to the fact a UDF is volatile, of course the sheet runs a little slow.

Is there any type of alternative that might work but yet with a little more speed?

Order ID	SP Name
105-22-N45	Laura Callahan
108-6-N17	Janet Leverling
102-14-F81	Margaret Peacock
103-25-F62	Robert King
106-12-N66	Steven Buchanan
103-14-N28	Nancy Davolio
105-21-F44	Andrew Fuller
109-26-N77	Michael Suyama
102-15-N56	Anne Dodsworth
108-6-N17	Cisneros Gilberto
102-14-F81	Cooper Tyrese
103-25-F62	Dudley Cooper
106-12-N66	Ball Parker
103-14-N28	Barry Milo
103-25-F62	Phillips Bronson
106-12-N66	Weber Gage
103-14-N28	Nolan Mike
106-12-N66	Moore Jaquan
103-14-N28	Mcdowell Cesar
103-14-N28	Zimmerman Colby

Order ID	Names
105-22-N45	Laura Callahan
108-6-N17	Janet Leverling / Cisneros Gilberto
102-14-F81	Margaret Peacock / Cooper Tyrese
103-25-F62	Robert King / Dudley Cooper / Phillips Bronson
106-12-N66	Steven Buchanan / Ball Parker / Weber Gage / Moore Jaquan
103-14-N28	Nancy Davolio / Barry Milo / Nolan Mike / Mcdowell Cesar / Zimmerman Colby
105-21-F44	Andrew Fuller
109-26-N77	Michael Suyama
102-15-N56	Anne Dodsworth

Function ConcatenateIf(CriteriaRange As Range, Condition As Variant, _
        ConcatenateRange As Range, Optional Separator As String = ",") As Variant
    Dim i As Long
    Dim strResult As String
    On Error GoTo ErrHandler
    If CriteriaRange.Count <> ConcatenateRange.Count Then
        ConcatenateIf = CVErr(xlErrRef)
        Exit Function
    End If
    For i = 1 To CriteriaRange.Count
        If CriteriaRange.Cells(i).Value = Condition Then
            If ConcatenateRange.Cells(i).Value <> "" Then
                strResult = strResult & Separator & ConcatenateRange.Cells(i).Value
            End If
        End If
    Next i
    If strResult <> "" Then
        strResult = Mid(strResult, Len(Separator) + 1)
    End If
    ConcatenateIf = strResult
    Exit Function
ErrHandler:
    ConcatenateIf = CVErr(xlErrValue)
End Function

 

[kevin9999]

I can't tell from your supplied images if the 2 tables are on the same sheet, what the sheet name(s) are, or if the Order ID and names columns are in columns A & B - or not.

The following code (in a standard module) assumes the first table is on sheet 1, the second table is on sheet 2, and the columns are A & B.

Option Explicit
Sub Concat_Names()
    Application.ScreenUpdating = False
    Dim lr As Long
    lr = Sheet2.Cells.Find("*", , xlFormulas, , 1, 2).Row
    If lr > 1 Then Sheet2.Range("A2:B" & lr).ClearContents
    
    Dim d As Object, arr1, arr2, arrOut, i As Long, j As Long
    Set d = CreateObject("scripting.dictionary")
    arr1 = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, "B").End(xlUp))
    For i = 1 To UBound(arr1, 1)
        d(arr1(i, 1)) = 1
    Next i
    Sheet2.Cells(1, 1).Resize(d.Count, 1).Value = Application.Transpose(d.keys)
    ReDim arrOut(1 To d.Count, 1 To 1)
    
    arr2 = Sheet2.Range("A2", Sheet2.Cells(Rows.Count, "A").End(xlUp))
    
    For i = 1 To UBound(arr2, 1)
        For j = 1 To UBound(arr1, 1)
            If arr1(j, 1) = arr2(i, 1) Then
            arrOut(i, 1) = Application.TextJoin(" / ", True, arrOut(i, 1), arr1(j, 2))
            End If
        Next j
    Next i
    
    Sheet2.Range("B2").Resize(d.Count).Value = arrOut
    Application.ScreenUpdating = True
End Sub

Personally, I would have this code triggered by a worksheet_change event, to make the process automatic.

 

[Rick Rothstein]

With the same layout that Kevin assumed, this macro should also work...

Sub Test()
  Dim R As Long, Data As Variant
  Data = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp))
  Sheets("Sheet1").Range("A1:B1").Copy Sheets("Sheet2").Range("A1:B1")
  With CreateObject("Scripting.Dictionary")
    For R = 1 To UBound(Data)
      .Item(Data(R, 1)) = .Item(Data(R, 1)) & " / " & Data(R, 2)
      If Left(.Item(Data(R, 1)), 3) = " / " Then .Item(Data(R, 1)) = Mid(.Item(Data(R, 1)), 4)
    Next
    Sheets("Sheet2").Range("A2").Resize(.Count) = Application.Transpose(.Keys)
    Sheets("Sheet2").Range("B2").Resize(.Count) = Application.Transpose(.Items)
  End With
End Sub

 

[kevin9999]

With the same layout that Kevin assumed, this macro should also work...

Sub Test()
  Dim R As Long, Data As Variant
  Data = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Cells(Rows.Count, "B").End(xlUp))
  Sheets("Sheet1").Range("A1:B1").Copy Sheets("Sheet2").Range("A1:B1")
  With CreateObject("Scripting.Dictionary")
    For R = 1 To UBound(Data)
      .Item(Data(R, 1)) = .Item(Data(R, 1)) & " / " & Data(R, 2)
      If Left(.Item(Data(R, 1)), 3) = " / " Then .Item(Data(R, 1)) = Mid(.Item(Data(R, 1)), 4)
    Next
    Sheets("Sheet2").Range("A2").Resize(.Count) = Application.Transpose(.Keys)
    Sheets("Sheet2").Range("B2").Resize(.Count) = Application.Transpose(.Items)
  End With
End Sub

Much better Rick

 

[FryGirl]

Thank you both Kevin and Rick. Much appreciated.