Append text from multiple cells in subsequent rows

Cross posted on mrexcel: https://www.mrexcel.com/board/…-subsequent-rows.1154617/

Hi Folks,

I've got a spreadsheet of codes and descriptions. Some descriptions only fall on one row, others are longer and fall into multiple rows (sometimes up to 60+ rows). I'm trying to figure out a way to easily append the text from those code descriptions over multiple rows into the top line for that code

Example:

Any help here would be greatly appreciated because I've got 18000 rows * 15 separate sheets that need to be completed the same way

Thanks in advance!

Quote from trunten

See if this works for you

Code

1. Sub Macro1()
2. Dim d, a, k, i&, s$
4. a = ActiveSheet.UsedRange.Value
5. If Not IsArray(a) Then Exit Sub
6. Set d = CreateObject("Scripting.Dictionary")
7. For i = 1 To UBound(a)
8. If d.exists(a(i, 1)) Then
9. s = d(a(i, 1)) & vbLf & a(i, 3)
10. Else
11. s = a(i, 3)
12. End If
13. d(a(i, 1)) = s
14. Next i
15. If d.Count > 0 Then
16. i = 0
17. ReDim a(1 To d.Count, 1 To 2)
18. For Each k In d.keys
19. i = i + 1
20. a(i, 1) = k
21. a(i, 2) = d(k)
22. Next k
23. With Workbooks.Add.Sheets(1).Range("A1").Resize(UBound(a), UBound(a, 2))
24. .Value = a
25. .EntireColumn.AutoFit
26. .EntireRow.AutoFit
27. End With
28. End If
29. Set d = Nothing
30. Erase a
31. End Sub

Display More

Almost worked perfectly, but I lost some leading 0s on some codes. Another user on MrExcel was able to come up with a solution as well that is working perfectly for me though.

Thanks so much for the help, interesting to see the similar but different paths to get to the same output!