need macro help to concatenate columns based on criteria

[Gogleguy]

Dear All,

Need help to create a macro which will give me the output as given in Column I (Output). Column C, D, E, F needs to be concatenated and then the macro needs to provide data for each "Supervisor Email" together in a single cell in Column I. The number of rows in the data keep changing so the macro needs to find till the last supervisor email in Column A. Please help

A​	B​	C​	D​	E​	F​	G​	H​	I​
Supervisor Email	Supervisor First Name	User Preferred Language	User Full Name	User Email Address	User Overdue Count	User overdue	Supervisor Overdue	Output (tab between values)​
random.name10@gogle.com	Random name10	English (English)	random name1	random.name1@gogle.com	Read/Complete	1	28	random name1 random.name1@gogle.com Read/Complete 1
random.name11@gogle.com	Random name11	English (English)	random name2	random.name2@gogle.com	Read/Complete	4	0	random name2 random.name2@gogle.com Read/Complete 4 random name3 random.name3@gogle.com Read/Complete 2
			random name3	random.name3@gogle.com	Read/Complete	2	0
random.name12@gogle.com	Random name12	English (English)	random name4	random.name4@gogle.com	Read/Complete	8	2	random name4 random.name4@gogle.com Read/Complete 8 random name5 random.name5@gogle.com Approval 7 random name6 random.name6@gogle.com Read/Complete 5 random name7 random.name7@gogle.com Approval 6
			random name5	random.name5@gogle.com	Approval	7	0
			random name6	random.name6@gogle.com	Read/Complete	5	0
			random name7	random.name7@gogle.com	Approval	6	0

 

[Alex Blakenburg]

Welcome to the Forum.

Give this a try:

Sub ConcatenateUserInfo_v02()

    Dim sht As Worksheet
    Dim rowLast As Long
    Dim rng As Range
    Dim arr As Variant
    Dim rowSuper As Long, rowSuperPrev As Long
    Dim outString As String
    Dim i As Long
   
   
    Set sht = ActiveSheet
    With sht
        rowLast = .Range("D" & Rows.Count).End(xlUp).Row
        Set rng = .Range(.Cells(2, "A"), .Cells(rowLast + 1, "I"))  ' Add 1 blank row to simplify logic
        arr = rng.Value
    End With

    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Or i = UBound(arr) Then
            rowSuperPrev = rowSuper
            If rowSuperPrev <> 0 Then
                arr(rowSuperPrev, 9) = Left(outString, Len(outString) - 1)
                If i = UBound(arr) Then Exit For
            End If
            rowSuper = i
            outString = ""
        End If
        outString = outString & _
                            arr(i, 4) & " " & _
                            arr(i, 5) & " " & _
                            arr(i, 6) & " " & _
                            arr(i, 7) & Chr(10)
   
    Next i
   
    With rng.Columns(9)
        .Value = Application.Index(arr, 0, 9)
        .WrapText = True
    End With
   
    rng.EntireRow.AutoFit

End Sub

 

[Gogleguy]

Welcome to the Forum.

Give this a try:

Sub ConcatenateUserInfo_v02()

    Dim sht As Worksheet
    Dim rowLast As Long
    Dim rng As Range
    Dim arr As Variant
    Dim rowSuper As Long, rowSuperPrev As Long
    Dim outString As String
    Dim i As Long
  
  
    Set sht = ActiveSheet
    With sht
        rowLast = .Range("D" & Rows.Count).End(xlUp).Row
        Set rng = .Range(.Cells(2, "A"), .Cells(rowLast + 1, "I"))  ' Add 1 blank row to simplify logic
        arr = rng.Value
    End With

    For i = 1 To UBound(arr)
        If arr(i, 1) <> "" Or i = UBound(arr) Then
            rowSuperPrev = rowSuper
            If rowSuperPrev <> 0 Then
                arr(rowSuperPrev, 9) = Left(outString, Len(outString) - 1)
                If i = UBound(arr) Then Exit For
            End If
            rowSuper = i
            outString = ""
        End If
        outString = outString & _
                            arr(i, 4) & " " & _
                            arr(i, 5) & " " & _
                            arr(i, 6) & " " & _
                            arr(i, 7) & Chr(10)
  
    Next i
  
    With rng.Columns(9)
        .Value = Application.Index(arr, 0, 9)
        .WrapText = True
    End With
  
    rng.EntireRow.AutoFit

End Sub

This works perfect. Thank you so much Alex. Really appreciate your help.