VBA to combine related strings into one cell, with char(10) separator

squidmark

squidmark

Board Regular
Joined
Aug 1, 2007
Messages
105
Hi everyone.

Please, save me from the purgatory that is going through 62,000 lines manually.

I've got a list of notes some 62,000 lines long. Column A is the customer number. Column B is the note.

I need to combine all of the notes in column B into a single cell with the other notes relating to the common customer, with a carriage return (char(10)) in between, putting them each on a different line in the same cell.

There are customers with more than 50 notes, so no form of if/then is going to work (that I know of).

Sample Data, each line is in a different row, so the following would be in the A1:B13 range:

ColA ColB

3500 8/18/2010 - lvm for A/P
3500 1/4/2011 - emld RE pmt stat
3500 2/3/2011 - emld RE pmt stat
3848 2/3/2011 - lvm for A/P
3848 1/13/2011 - lvm for A/P
3848 1/28/2011 - lvm for A/P
3860 2/3/2011 - emld RE pmt stat
3860 3/8/2011 - emld RE pmt stat
3860 4/5/2011 - emld RE pmt stat
3860 3/4/2011 - lvm for A/P
3860 2/10/2011 - lvm for A/P
3860 8/18/2010 - clld & n/a
3860 8/12/2010 - called & N/A

The sample below would end up in three cells, as in the following (the range here would be A1:B3, as all the notes for customer 3500 are in cell B1, all those for customer 3848 are in cell B2, etc...)

ColA ColB
3500 8/18/2010 - lvm for A/P
....... 1/4/2011 - emld RE pmt stat
....... 2/3/2011 - emld RE pmt stat
3848 2/3/2011 - lvm for A/P
...... 1/13/2011 - lvm for A/P
...... 1/28/2011 - lvm for A/P
3860 2/3/2011 - emld RE pmt stat
...... 3/8/2011 - emld RE pmt stat
...... 4/5/2011 - emld RE pmt stat
...... 3/4/2011 - lvm for A/P
...... 2/10/2011 - lvm for A/P
...... 8/18/2010 - clld & n/a
...... 8/12/2010 - called & N/A

(the dots are supposed to be blanks, but I'm having formatting issues)

There has to be a good VBA way to do this. But I'm just starting to learn VBA and this is kicking my rear-end.
 
Last edited:

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
Sort by date Sort by votes
Try something like this.
Note: 62K rows could take minutes to complete.
Test this on a copy of your data.

Code: 
Sub Consolidate_Notes()

    Dim strTemp As String
    Dim rngUniques As Range, cell As Range
    Dim LastRow As Long

    Application.ScreenUpdating = False

    Range("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
    Rows(1).Insert: Range("A1") = "Header"
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & LastRow).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Rows(1).Delete

    For Each cell In rngUniques
        strTemp = cell.Value
        Range("A:A").Replace strTemp, True, xlWhole
        cell.Offset(, 1).Value = Join(WorksheetFunction.Transpose( _
            Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).Offset(, 1)), vbLf)
        cell.Value = strTemp
        Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).ClearContents
    Next cell
    Range("A1:A" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Range("B:B").ColumnWidth = 100  'Autofit rows and column B
    Range("B:B").Columns.AutoFit    '
    Cells.Rows.AutoFit              '

    Application.ScreenUpdating = True

End Sub
 
Upvote 0
AlphaFrog said:
Try something like this.
Note: 62K rows could take minutes to complete.
Test this on a copy of your data.

Code: 
Sub Consolidate_Notes()

    Dim strTemp As String
    Dim rngUniques As Range, cell As Range
    Dim LastRow As Long

    Application.ScreenUpdating = False

    Range("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
    Rows(1).Insert: Range("A1") = "Header"
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & LastRow).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Rows(1).Delete

    For Each cell In rngUniques
        strTemp = cell.Value
        Range("A:A").Replace strTemp, True, xlWhole
        cell.Offset(, 1).Value = Join(WorksheetFunction.Transpose( _
            Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).Offset(, 1)), vbLf)
        cell.Value = strTemp
        Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).ClearContents
    Next cell
    Range("A1:A" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Range("B:B").ColumnWidth = 100  'Autofit rows and column B
    Range("B:B").Columns.AutoFit    '
    Cells.Rows.AutoFit              '

    Application.ScreenUpdating = True

End Sub
Click to expand...

Wow. Thanks for putting that together. I'm getting a run-time error: Type mismatch at this point:

cell.Offset(, 1).Value = Join(WorksheetFunction.Transpose( _
Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).Offset(, 1)), vbLf)

Do you know what would cause that?

Thanks for your help.
 
Upvote 0
It has a problem when trying to consolidate notes for only one cell . This should fix it.

Code: 
Sub Consolidate_Notes()

    Dim strTemp As String
    Dim rngUniques As Range, cell As Range
    Dim LastRow As Long

    Application.ScreenUpdating = False

    Range("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
    Rows(1).Insert: Range("A1") = "Header"
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & LastRow).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Rows(1).Delete

    For Each cell In rngUniques
        If cell.Value = cell.Offset(1).Value Then
            strTemp = cell.Value
            Range("A:A").Replace strTemp, True, xlWhole
            cell.Offset(, 1).Value = Join(WorksheetFunction.Transpose( _
                Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).Offset(, 1)), vbLf)
            cell.Value = strTemp
            Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).ClearContents
        End If
    Next cell
    Range("A1:A" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Range("B:B").ColumnWidth = 100  'Autofit rows and column B
    Range("B:B").Columns.AutoFit    '
    Cells.Rows.AutoFit              '

    Application.ScreenUpdating = True

End Sub
 
Upvote 0
Here is another macro for you to try out....
Code: 
Sub CombineCustomerNotes()
  Dim X As Long, LastRow As Long, R As Range, Cell As Range
  Const StartRow As Long = 1
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Application.ScreenUpdating = False
  X = StartRow
  On Error Resume Next
  Do While X < LastRow
    Set R = Range(Cells(X + 1, "A"), Cells(LastRow, "A"))
    If Len(Cells(X, "A")) Then R.Replace Cells(X, "A").Value, "", xlWhole
    X = X + 1
    X = X + R.SpecialCells(xlCellTypeBlanks).Rows.Count
  Loop
  On Error GoTo 0
  Set R = Range("A" & StartRow & ":A" & LastRow).SpecialCells(xlCellTypeBlanks)
  For Each Cell In R.Areas
    Cell(1).Offset(-1, 1) = Join(WorksheetFunction.Transpose(Cell(1).Offset(-1, 1).Resize(1 + Cell.Rows.Count)), vbLf)
  Next
  R.EntireRow.Delete
  Application.ScreenUpdating = True
End Sub
 
Upvote 0
You could just sort on column A and then use Conditional Formatting (on A2 copied down) with the formula to make the font white.
=(A1=A2)
 
Upvote 0
AlphaFrog said:
It has a problem when trying to consolidate notes for only one cell . This should fix it.

Code: 
Sub Consolidate_Notes()

    Dim strTemp As String
    Dim rngUniques As Range, cell As Range
    Dim LastRow As Long

    Application.ScreenUpdating = False

    Range("A:B").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess
    Rows(1).Insert: Range("A1") = "Header"
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A1:A" & LastRow).AdvancedFilter _
            Action:=xlFilterInPlace, Unique:=True
    Set rngUniques = Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
    Rows(1).Delete

    For Each cell In rngUniques
        If cell.Value = cell.Offset(1).Value Then
            strTemp = cell.Value
            Range("A:A").Replace strTemp, True, xlWhole
            cell.Offset(, 1).Value = Join(WorksheetFunction.Transpose( _
                Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).Offset(, 1)), vbLf)
            cell.Value = strTemp
            Range("A:A").SpecialCells(xlCellTypeConstants, xlLogical).ClearContents
        End If
    Next cell
    Range("A1:A" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

    Range("B:B").ColumnWidth = 100  'Autofit rows and column B
    Range("B:B").Columns.AutoFit    '
    Cells.Rows.AutoFit              '

    Application.ScreenUpdating = True

End Sub
Click to expand...

B.I.N.G.O. That works great. Thank you.
I don't suppose there's any way to get it to work without having text wrapping on, is there?
Thank you so much for this solution.
 
Upvote 0
Rick Rothstein said:
Here is another macro for you to try out....
Code: 
Sub CombineCustomerNotes()
  Dim X As Long, LastRow As Long, R As Range, Cell As Range
  Const StartRow As Long = 1
  LastRow = Cells(Rows.Count, "A").End(xlUp).Row
  Application.ScreenUpdating = False
  X = StartRow
  On Error Resume Next
  Do While X < LastRow
    Set R = Range(Cells(X + 1, "A"), Cells(LastRow, "A"))
    If Len(Cells(X, "A")) Then R.Replace Cells(X, "A").Value, "", xlWhole
    X = X + 1
    X = X + R.SpecialCells(xlCellTypeBlanks).Rows.Count
  Loop
  On Error GoTo 0
  Set R = Range("A" & StartRow & ":A" & LastRow).SpecialCells(xlCellTypeBlanks)
  For Each Cell In R.Areas
    Cell(1).Offset(-1, 1) = Join(WorksheetFunction.Transpose(Cell(1).Offset(-1, 1).Resize(1 + Cell.Rows.Count)), vbLf)
  Next
  R.EntireRow.Delete
  Application.ScreenUpdating = True
End Sub
Click to expand...

Thanks, Rick. I did try this one, but got a runtime-error, "Application defined or object defined error at this point:
Cell(1).Offset(-1, 1) = Join(WorksheetFunction.Transpose(Cell(1).Offset(-1, 1).Resize(1 + Cell.Rows.Count)), vbLf)

Thanks.
 
Upvote 0
squidmark said:
B.I.N.G.O. That works great. Thank you.
I don't suppose there's any way to get it to work without having text wrapping on, is there?
Thank you so much for this solution.
Click to expand...

You're welcome.

Code: 
    [COLOR="Red"]Columns("B:B").WrapText = False[/COLOR]
    Application.ScreenUpdating = True

End Sub

Macro Tip: you can can record a small macro to get example bits of code to add to your main macro.
 
Upvote 0
squidmark said:
Thanks, Rick. I did try this one, but got a runtime-error, "Application defined or object defined error at this point:
Cell(1).Offset(-1, 1) = Join(WorksheetFunction.Transpose(Cell(1).Offset(-1, 1).Resize(1 + Cell.Rows.Count)), vbLf)
Click to expand...
I'm not sure why that is happening to you. I tested the code before I posted it (and I tested it again just to be sure) and it works fine here. What I did is copy your data from you posting, split it into two columns using "Data/Text To Columns" and then run my code against it... worked (and still works) perfectly here.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Using VBA to select a color coded cell
2
Replies
11
Views
953
Alex Blakenburg
A
S
  • Solved
Need help modifying an Excel VBA coded to add a check for new hires less that 90 days.
Replies
1
Views
515
spittingfire
S
H
  • Solved
Find a subject that is in column "P" in columns "G" and "L" and export.
Replies
2
Views
253
harzer
H
D
  • Question Question
Copy/Pasting rows of a table to specific cells of a separate worksheet template and exporting as a new file.
Replies
0
Views
217
DjentChicken
D
F
  • Question Question
VBA to copy and insert a row below only if a certain criteria is met
Replies
2
Views
221
feni1388
F

Forum statistics

Threads
1,224,597
Messages
6,179,808
Members
452,944
Latest member
2558216095

Share this page

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