Append text from multiple cells in subsequent rows

hoopsta1423

New Member
Joined
Nov 30, 2020
Messages
5
Office Version
  1. 2016
Platform
  1. Windows
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:

CODELINE NUMBERDESCRIPTION
2651This description continues for
2652multiple lines and I need
2653to combine them into a single
2654row, some descriptions continue for 60+ lines
3651This line also continues below
3652but stops at two lines
7651This description thankfully only takes up one row

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!
 

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"
Do you want to delete the other rows?
 
Upvote 0
Do you mean delete rows where line number not equal to 1 after appending the descriptions to rows where line number=1?

If so, then yes that would be great too!
 
Upvote 0
CODELINE NUMBERDESCRIPTIONCODEDescription
2651This description continues for265This description continues for multiple lines and I need to combine them into a single row, some descriptions continue for 60+ lines
2652multiple lines and I need365This line also continues below but stops at two lines
2653to combine them into a single765This description thankfully only takes up one row
2654row, some descriptions continue for 60+ lines
3651This line also continues below
3652but stops at two lines
7651This description thankfully only takes up one row

Power Query:
let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Group = Table.Group(Source, {"CODE"}, {{"Count", each _, type table}}),
    List = Table.AddColumn(Group, "Description", each [Count][DESCRIPTION]),
    Extract = Table.TransformColumns(List, {"Description", each Text.Combine(List.Transform(_, Text.From), " "), type text})
in
    Extract
 
Upvote 0
How about
VBA Code:
Sub hoopsta()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, nr As Long
   
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To 3)
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), nr
            Nary(nr, 1) = Ary(r, 1)
            Nary(nr, 2) = Ary(r, 2)
            Nary(nr, 3) = Ary(r, 3)
         Else
            Nary(.Item(Ary(r, 1)), 3) = Nary(.Item(Ary(r, 1)), 3) & " " & Ary(r, 3)
         End If
      Next r
   End With
   Range("A1").CurrentRegion.Offset(1).ClearContents
   Range("A2").Resize(nr, 3).Value = Nary
End Sub
If this is ok, we can expand it to cover the other sheets as well
 
Upvote 0
Solution
How about
VBA Code:
Sub hoopsta()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, nr As Long
  
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To 3)
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), nr
            Nary(nr, 1) = Ary(r, 1)
            Nary(nr, 2) = Ary(r, 2)
            Nary(nr, 3) = Ary(r, 3)
         Else
            Nary(.Item(Ary(r, 1)), 3) = Nary(.Item(Ary(r, 1)), 3) & " " & Ary(r, 3)
         End If
      Next r
   End With
   Range("A1").CurrentRegion.Offset(1).ClearContents
   Range("A2").Resize(nr, 3).Value = Nary
End Sub
If this is ok, we can expand it to cover the other sheets as well

This worked almost perfectly!!!

A couple minor issues:

1. For whatever reason, one code was not sorted correctly (ie, Line Number=2 came before Line Number=1) so the description was converted to something like"

"but stops at two lines The line also continues below"

2. The other issue is that some descriptions have multiple spaces/tabs at the end of the line, so they end up looking like:

"The line also continues below but stops at two lines"

Is it simple enough to add the ability to sort by "CODE" followed by "LINE NUMBER", and then TRIM the descriptions prior to appending the text?

Thanks so much for the help, this is wonderful!
 
Upvote 0
This worked almost perfectly!!!

A couple minor issues:

1. For whatever reason, one code was not sorted correctly (ie, Line Number=2 came before Line Number=1) so the description was converted to something like"

"but stops at two lines The line also continues below"

2. The other issue is that some descriptions have multiple spaces/tabs at the end of the line, so they end up looking like:

"The line also continues below but stops at two lines"

Is it simple enough to add the ability to sort by "CODE" followed by "LINE NUMBER", and then TRIM the descriptions prior to appending the text?

Thanks so much for the help, this is wonderful!

Actually I had a go at it and it seems to have worked

VBA Code:
Sub hoopsta()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, nr As Long
   Dim Addr As String
   
   Columns.Sort key1:=Columns("A"), Order1:=xlAscending, Key2:=Columns("B"), Order2:=xlAscending, Header:=xlYes
   Addr = "C1:C" & Cells(Rows.Count, "C").End(xlUp).Row
   Range(Addr) = Evaluate("IF(" & Addr & "="""","""",TRIM(" & Addr & "))")
   Ary = Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary), 1 To 3)
   With CreateObject("scripting.dictionary")
      For r = 2 To UBound(Ary)
         If Not .Exists(Ary(r, 1)) Then
            nr = nr + 1
            .Add Ary(r, 1), nr
            Nary(nr, 1) = Ary(r, 1)
            Nary(nr, 2) = Ary(r, 2)
            Nary(nr, 3) = Ary(r, 3)
         Else
            Nary(.Item(Ary(r, 1)), 3) = Nary(.Item(Ary(r, 1)), 3) & " " & Ary(r, 3)
         End If
      Next r
   End With
   Range("A1").CurrentRegion.Offset(1).ClearContents
   Range("A2").Resize(nr, 3).Value = Nary
End Sub
 
Upvote 0
Glad you sorted it & thanks for the feedback.
 
Upvote 0

Forum statistics

Threads
1,213,513
Messages
6,114,072
Members
448,546
Latest member
KH Consulting

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top