Merging multiple header row contents into one cell

emmorel · #1 06-27-2018, 08:22 AM

I am working on an Excel table that has an account header row and details rows of codes under that account. Each account can have a different number of codes. I want to be able to merge all the codes into a single cell separated by comma next the corresponding account number without having to do it manually for each account. I am using the concatenate function as shown above. Is there a Macro I can develop to do this automatically?
Help. I am stumped.
emmorel

NoSparks · #2 06-27-2018, 02:43 PM

perhaps something along the lines of this ?

Code:

Sub MergeCodes()
    Dim i As Long, lr As Long
    Dim rng As Range, cel As Range
    Dim str As String
    
With Sheets("Sheet1")    '<~~ change to actual sheet name
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    Set rng = .Range("A2:A" & lr)
End With
    
    For Each cel In rng
        If Len(cel.Value) = 10 Then
            For i = 1 To lr
                If Len(cel.Offset(i).Value) < 10 And cel.Offset(i).Value <> "" Then
                    str = str & ", " & cel.Offset(i).Value
                Else
                    cel.Offset(, 1).Value = Mid(str, 3)
                    str = ""
                    Exit For
                End If
            Next i
        End If
    Next cel
    
End Sub

emmorel · #3 06-28-2018, 03:54 PM

Thank you for your help NoSparks. The suggested Vba Macro provided the results I was looking for. Below is a small sample of the output. emmorel

1001017255
36415, 82310, 82330, 82784, 82785, 83970, 84436, 84443, 85025, 86359, 86360
36415
82310
82330
82784
82785
83970
84436
84443
85025
86359
86360
1001113575
36415, 83655, 86003
36415
83655
86003
1001148250
36415, 82785, 86003
36415
82785
86003
1001164885
36415, 82785, 86003
36415
82785
86003
1001211245
36415, 86003
36415
86003

NoSparks · #4 06-28-2018, 08:15 PM

Quote:

Originally Posted by emmorel

The suggested Vba Macro provided the results I was looking for. Below is a small sample of the output.

By chance is there a few words missing in the above quote?

Are you now saying the new sample output is what you would prefer?
If so, try this way

Code:

Sub MergeCodes_v2()
    Dim i As Long, lr As Long
    Dim rng As Range, cel As Range
    Dim str As String
    
With Sheets("Sheet1")    '<~~ change to actual sheet name
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    'add row for merge string
    For i = lr To 2 Step -1
        If Len(.Cells(i, "A")) = 10 Then
            .Rows(i + 1).Insert
        End If
    Next i
    'recalc lastrow
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    Set rng = .Range("A2:A" & lr)
End With
    
For Each cel In rng
    cel.Select
    If cel.Value = "" Then
        For i = 1 To lr
            If Len(cel.Offset(i).Value) < 10 And cel.Offset(i).Value <> "" Then
                str = str & ", " & cel.Offset(i).Value
            Else
                cel.Value = Mid(str, 3)
                cel.Font.Bold = False
                str = ""
                Exit For
            End If
        Next i
    End If
Next cel
    
End Sub

ArviLaanemets · #5 06-28-2018, 10:49 PM

There was a way to do this manually too.

1. Copy HAR and it's components codes, and PasteSpecial>Transpose into new workbook. Like
1000639594 35415 86003
1000687858 36415 82785 83520 ...;

2. Save the new workbook as comma-delimited text file;

3. Open the text file with Excel without splitting (i.e. comma-delimited string remains in same cell);

4. Before the column with comma-delimited list, add 2 columns. Into 1st one, enter the formula to get HAR code from comma-delimited list (the leftmost one). In second one, use SUBSTITUTE() to get the comma-delimited list without HAR code (read from 1st column);

5. Copy columns with formulas, and overwrite them with PasteSpecial>Values. Delete column with original comma-delimited list. Save as Excel file.

It's done.

emmorel · #6 06-29-2018, 09:31 AM

Quote:

Originally Posted by NoSparks

By chance is there a few words missing in the above quote?

Are you now saying the new sample output is what you would prefer?
If so, try this way

Code:

Sub MergeCodes_v2()
    Dim i As Long, lr As Long
    Dim rng As Range, cel As Range
    Dim str As String
    
With Sheets("Sheet1")    '<~~ change to actual sheet name
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    'add row for merge string
    For i = lr To 2 Step -1
        If Len(.Cells(i, "A")) = 10 Then
            .Rows(i + 1).Insert
        End If
    Next i
    'recalc lastrow
    lr = .Range("A" & Rows.Count).End(xlUp).Row
    Set rng = .Range("A2:A" & lr)
End With
    
For Each cel In rng
    cel.Select
    If cel.Value = "" Then
        For i = 1 To lr
            If Len(cel.Offset(i).Value) < 10 And cel.Offset(i).Value <> "" Then
                str = str & ", " & cel.Offset(i).Value
            Else
                cel.Value = Mid(str, 3)
                cel.Font.Bold = False
                str = ""
                Exit For
            End If
        Next i
    End If
Next cel
    
End Sub

Nosparks, the initial Vba macro you provided worked fine. When I pasted the sample data somehow the merged codes moved under the header. They actually displayed next to the header when I ran the macro which is what I wanted. Thanks! This thread can be marked SOLVED! emmorel

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Merging 2 different cells containing IF formula & change in cell values based on multiple time frame	jay_excel	Excel	0	07-29-2017 11:04 PM
Selection from cell with list contents autopopulates contents of another cell	markharper80	Excel	3	02-16-2015 04:18 PM
Merging multiple .txt's	Bartestokles	Word	5	12-29-2010 01:42 PM
Merging Multiple Copies of the Same Document	bshatto	Word	0	10-19-2009 06:22 AM
How to eliminate Header on Contents Page	George99	Word	1	12-06-2008 09:59 AM