Macro or function to copy multiple string cells into one cell

[nbonanno]

Have a user who used Excel like lined paper. For each "record, " one column could have between one and 20 cells. I need to turn this spreadsheet into a one-row-is-one-record sheet.

Is there a way to create a macro or function that says "concatenate cells from the column to the left until you get to a blank cell OR a dark formatted line"?

In the attached example image, the first two columns are indicative of the data. No standard number of rows or cells.... Cell C2, in red, is what I'm hoping to create from the data.

Is it doable? Thank you.

 

[kennypete]

Hi @nbonanno, I reckon someone will have a formula for this but since you have asked for a macro as an option, this would work:

Sub macro_to_copy_multiple_string_cells_into_one_1175711()

    Dim d As Object, r As Range, n As Integer, k As String
    Set d = CreateObject("Scripting.Dictionary")
    Set r = ActiveSheet.UsedRange
 
    For n = 2 To r.Rows.Count
        If Len(Cells(n, 1)) > 0 Then
            k = Trim(Cells(n, 1))
            d.Add Key:=k, Item:=Cells(n, 2)
        ElseIf Len(Cells(n, 2)) > 0 Then
            d.Item(k) = d.Item(k) + " | " + Cells(n, 2)
        Else
            'do nothing
        End If
    Next n

    For n = 2 To r.Rows.Count
        If d.Exists(Trim(Cells(n, 1))) Then
            k = Trim(Cells(n, 1))
            Cells(n, 3) = d.Item(k)
        End If
    Next n

End Sub

I tested it on this:

...and the output is:

Of course, you could (which is what I presume you will do) delete the empty heading rows at the same time with a small tweak.

 

[nbonanno]

Okay, thank you! Let me give this a try and I'll get back to you.

 

[nbonanno]

Wow, I'm learning so much from you just picking this macro apart. But I created your test sheet and added the macro and ran it, and I'm getting the error "Run-time error 457. This key is already associated with an element of this collection." The first time I ran the macro, it seemed like it had that error when I headed for the second "n=2" section but now it has that error as soon as I pass the highlighted line the first time. I don't know anyting about how to use "add" so I'm not sure what to change? Any suggestions what I'm doing wrong?

 

[kennypete]

It's likely the same name repeats in column A. I did not put handling in for that because I expected all case entries to be unique. A VBA dictionary's keys must be unique, so you cannot add a key that already exists...and the only way that can be happening is if two occurrances of text longer than one character are appearing. I guess it's also possible some cells are just spaces, so I'll also look to handle that too (i.e. treat them as empty).

I will look to adding those enhancements shortly and also add some comments to the code since you're finding it useful.

 

[nbonanno]

It's so weird. This is the very first pass through the program. You can see the data in the image to the left. In the "watches" you can see that the Key has been named "HEADING" but if I press F8, it crashes with that error. So is it running the first half of that line, or what? I also have a blank item 1 as soon as I "Set d = "

 

[kennypete]

Yes, that is because, as I said, if the heading appears twice it will error under the original version I posted - that's because I presumed that your Case Names would be unique. In the example you show above "HEADING" appears in C2 and C10 so the script errors in trying to add a dictionary item with the same key.

This updated and commented script handles that:

Sub macro_to_copy_multiple_string_cells_into_one_1175711()

    ' Since this is a quick, and likely only used once, script, plus the
    ' types only occur once, the variables are single characters only for simplicity
    Dim d As Object, r As Range, n As Integer, k As String
    ' Create a late binding VBA dictionary, d; this could be a early bound
    ' dictionary to enable intellisense, etc., but as this is Mr Excel, I have
    ' used late binding to avoid needing a Reference call, which then needs to
    ' be exaplained as well as being another thing that can fail. Refer:
    ' https://excelmacromastery.com/vba-dictionary/#Early_versus_Late_Binding
    ' for a better explanation.
    Set d = CreateObject("Scripting.Dictionary")
    ' For expediency I have used the active sheet's used range. This means that
    ' if there is some rogue data in cell XFD1048576 (for example) it could add the
    ' whole sheet into the range, but I'll presume that the range is truly limited to
    ' a logical, used, area.
    Set r = ActiveSheet.UsedRange
   
    ' Loop through the range, starting from the second row as the first appears to
    ' only have row header information as so we do not want to consider it.
    For n = 2 To r.Rows.Count
        ' If the "heading" cell is only spaces (or empty) or and there is
        ' content in the corresponding data cell, then append the content to
        ' the dictionary with the key relating to the heading
        If Len(Replace(Cells(n, 1), " ", "")) = 0 And Len(Replace(Cells(n, 2), " ", "")) > 0 Then
            d.Item(k) = d.Item(k) + " | " + Cells(n, 2)
        ' Otherwise, if the "heading" cell has text other than just spaces, create
        ' a new dictionary item with the key for this heading. If it is a repeat heading
        ' (which is probably not allowed, but nonetheless) warn the user that the
        ' content will be added to that repeated heading.
        ElseIf Len(Cells(n, 1)) > 0 Then
            k = Trim(Cells(n, 1))
            If d.Exists(k) Then
                MsgBox "Case " & k & " is appearing more than once. Its content will be merged.", vbInformation
                d.Item(k) = d.Item(k) + " | " + Cells(n, 2)
            Else
                d.Add Key:=k, Item:=Cells(n, 2)
            End If
        Else
            'do nothing - this is a blank line
        End If
    Next n

    ' Now loop back through the range and...
    For n = 2 To r.Rows.Count
        ' Where there is a dictionary item with the key that matches the (trimmed
        ' of spaces) heading, output the concatenated (with space-pipe-space)
        ' string associated with that heading. Note: if the heading is a repeat it
        ' will do that for each instance.
        If d.Exists(Trim(Cells(n, 1))) Then
            k = Trim(Cells(n, 1))
            Cells(n, 3) = d.Item(k)
        End If
    Next n

End Sub

The test sheet:

Book1
	A	B	C
1	Case Name	Col 2	Col 2 Cat
2	Heading	Text1
3		Text2
4		Text3
5
6	Heading2	Text4
7		Text5
8		Text6
9	Heading3	Text7
10		Text8
11		Text9
12		Text10
13	Heading
14		Text11
Sheet1

Output:

Book1
	A	B	C
1	Case Name	Col 2	Col 2 Cat
2	Heading	Text1	Text1 | Text2 | Text3 | | Text11
3		Text2
4		Text3
5
6	Heading2	Text4	Text4 | Text5 | Text6
7		Text5
8		Text6
9	Heading3	Text7	Text7 | Text8 | Text9 | Text10
10		Text8
11		Text9
12		Text10
13	Heading		Text1 | Text2 | Text3 | | Text11
14		Text11
Sheet1

Noting the second instance of HEADING generates:

Note also, I have not specifically handled empty text following a heading (cell B13): it will not error, but it will be treated as an entry, which could be ignored when looping back through the range the second time by not outputting the item where it is only " | ".

 

[kennypete]

It's so weird. This is the very first pass through the program. You can see the data in the image to the left. In the "watches" you can see that the Key has been named "HEADING" but if I press F8, it crashes with that error. So is it running the first half of that line, or what? I also have a blank item 1 as soon as I "Set d = "

View attachment 42475

Sorry, I'd not seen first pass. The updated script above addresses the duplicate entries. I have no idea why the script would fail a second time when run but not the first when adding items to the dictionary other than if it had not actually been stopped and, instead, the IDE script -> line moved back up so that the dictionary was not reset. Without other information to debug it, I'd close Excel and start again with the revised script and see how that goes.

 

[nbonanno]

Oh. My. Gosh. This works perfectly. And I can't believe how much time you spent commenting. I'm learning a ton from this one macro. Thank you so much.

I can see about a zillion uses for this macro and I wanted to make it so a person could decide which columns to use, instead of just hard-coding to Columns 1 (the source) and 2 (the target). I thought I'd add Dimming "Vsource As Integer, Vtarget As Integer" and then add a message box that says something like, "be sure the cursor is in the first target cell. " Then I'd add,
Vtarget = ActiveCell.Column
Vsource = Vtarget - 1

And I'd replace the 1 and 2 (for example, in Cells(n,2)...) with Vtarget and Vsource. Does that sound like the best way to accomplish this?

(And if you haven't got time for this, no worries. You've done more than enough. Thank you again so much!)

 

[kennypete]

Oh. My. Gosh. This works perfectly. And I can't believe how much time you spent commenting. I'm learning a ton from this one macro. Thank you so much.

I can see about a zillion uses for this macro and I wanted to make it so a person could decide which columns to use, instead of just hard-coding to Columns 1 (the source) and 2 (the target). I thought I'd add Dimming "Vsource As Integer, Vtarget As Integer" and then add a message box that says something like, "be sure the cursor is in the first target cell. " Then I'd add,
Vtarget = ActiveCell.Column
Vsource = Vtarget - 1

And I'd replace the 1 and 2 (for example, in Cells(n,2)...) with Vtarget and Vsource. Does that sound like the best way to accomplish this?

(And if you haven't got time for this, no worries. You've done more than enough. Thank you again so much!)

Thanks @nbonanno and now worries, glad to help.

And yes, you're on the right track for making the columns non-fixed It was only a few lines plus some search and replace, so "V2" is below with that ability that added. (I tested with the same data as above, but in cols B and D, output to col G, and works fine. Cheers)

Sub macro_to_copy_multiple_string_cells_into_one_1175711()

    ' Since this is a quick, and likely only used once, script, plus the
    ' types only occur once, the variables are single characters only for simplicity
    Dim d As Object, r As Range, n As Integer, k As String
    ' Create a late binding VBA dictionary, d; this could be a early bound
    ' dictionary to enable intellisense, etc., but as this is Mr Excel, I have
    ' used late binding to avoid needing a Reference call, which then needs to
    ' be exaplained as well as being another thing that can fail. Refer:
    ' https://excelmacromastery.com/vba-dictionary/#Early_versus_Late_Binding
    ' for a better explanation.
    Set d = CreateObject("Scripting.Dictionary")
    ' For expediency I have used the active sheet's used range. This means that
    ' if there is some rogue data in cell XFD1048576 (for example) it could add the
    ' whole sheet into the range, but I'll presume that the range is truly limited to
    ' a logical, used, area.
    Set r = ActiveSheet.UsedRange
    
    ' Variables to hold the column numbers - extension to the original script so that
    ' it is more extensible.
    Dim hc As Integer ' heading column number
    Dim dc As Integer ' data column number
    Dim oc As Integer ' output column number
    
    ' Request the user to enter the column letters. NB: there is no error handling
    ' so this should be added if it is not going to be a temporary / limited
    ' use script.
    ' Convert the column letters entered to integers for use with: cells(r, c)
    hc = Range(InputBox("Heading column letter: ") & 1).Column
    dc = Range(InputBox("Data column letter: ") & 1).Column
    oc = Range(InputBox("Output column letter: ") & 1).Column
    
    ' Loop through the range, starting from the second row as the first appears to
    ' only have row header information as so we do not want to consider it.
    For n = 2 To r.Rows.Count
        ' If the "heading" cell is only spaces (or empty) or and there is
        ' content in the corresponding data cell, then append the content to
        ' the dictionary with the key relating to the heading
        If Len(Replace(Cells(n, hc), " ", "")) = 0 And Len(Replace(Cells(n, dc), " ", "")) > 0 Then
            d.Item(k) = d.Item(k) + " | " + Cells(n, dc)
        ' Otherwise, if the "heading" cell has text other than just spaces, create
        ' a new dictionary item with the key for this heading. If it is a repeat heading
        ' (which is probably not allowed, but nonetheless) warn the user that the
        ' content will be added to that repeated heading.
        ElseIf Len(Cells(n, hc)) > 0 Then
            k = Trim(Cells(n, hc))
            If d.Exists(k) Then
                MsgBox "Case " & k & " is appearing more than once. Its content will be merged.", vbInformation
                d.Item(k) = d.Item(k) + " | " + Cells(n, dc)
            Else
                d.Add Key:=k, Item:=Cells(n, dc)
            End If
        Else
            'do nothing - this is a blank line
        End If
    Next n

    ' Now loop back through the range and...
    For n = 2 To r.Rows.Count
        ' Where there is a dictionary item with the key that matches the (trimmed
        ' of spaces) heading, output the concatenated (with space-pipe-space)
        ' string associated with that heading. Note: if the heading is a repeat it
        ' will do that for each instance.
        If d.Exists(Trim(Cells(n, hc))) Then
            k = Trim(Cells(n, hc))
            Cells(n, oc) = d.Item(k)
        End If
    Next n

End Sub