Split concatenated cells over multiple rows

ewarthur

New Member
Joined
Oct 5, 2021
Messages
2
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Hello,

I have the following code which I want to amend to skip rows where there is no data. This macros looks at column J where there can be concatenated values, deiminated by a comma. The code then splits the concatenated values over new lines immediately below, copying the other columns with it. Finally, before moving on to the next row, Excel deletes the original row.

Sometimes column J is null and contains no values at all. In this instance, this is throwing an error and causing corruption in the results. I then see a particular record has values that don't belong to it once the macro has been run.

I'd like to amend the code below to check each time, if column J has data in it. If not, then go to the next row, without deleting this current row. It then goes to the next row with data and splits the concatenated data over as many rows as there are items to split ie ("car, bus, train" creates 3 new lines) and deletes the original line,

Thanks in advance if you can help.

VBA Code:
Sub ProcessCRM()

Dim lastrow As Integer
Dim i As Integer
Dim descriptions() As String

With Worksheets("Clients")
    lastrow = .Range("J2").End(xlDown).Row
    For i = lastrow To 2 Step -1
        If InStr(1, .Range("J" & i).Value, ",") <> 0 Then
            descriptions = Split(.Range("J" & i).Value, ",")
        End If
        For Each Item In descriptions
            .Range("J" & i).Value = Item
            .Rows(i).Copy
            .Rows(i).Insert
        Next Item
        .Rows(i).EntireRow.Delete

    Next i
End With


With Worksheets("Clients")
    lastrow = .Range("J2").End(xlDown).Row
    
    For i = 2 To lastrow
        .Cells(i, "J").Value = Trim(.Cells(i, "J").Value)
    Next i
End With


End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,773
Office Version
  1. 365
Platform
  1. Windows
Welcome to the MrExcel board!

What about some sample data and expected results so that we can see exactly what you have and what you want to achieve, and also have some sample data to test with?

MrExcel has a tool called “XL2BB” that lets you post samples of your data that will allow us to copy/paste it to our Excel spreadsheets, so we can work with the same copy of data that you are. Instructions on using this tool can be found here: XL2BB Add-in

Note that there is also a "Test Here” forum on this board. This is a place where you can test using this tool (or any other posting techniques that you want to test) before trying to use those tools in your actual posts.
 

Alex Blakenburg

Well-known Member
Joined
Feb 23, 2021
Messages
2,267
Office Version
  1. 365
Platform
  1. Windows
Try this:
Changes
1) xlDown won't work if you are expecting blanks in column J, changed to xlUp version
2) Your active code is outside the IF End If, moved inside the IF End If
3) Item was not defined, added Dim

VBA Code:
Sub ProcessCRMMod()

    Dim lastrow As Integer
    Dim i As Integer
    Dim descriptions() As String
    Dim item As Variant
  
    With Worksheets("Clients")
        'XXX Change from xlDown to xlUp
        lastrow = .Range("J" & Rows.Count).End(xlUp).Row
        For i = lastrow To 2 Step -1
            If InStr(1, .Range("J" & i).Value, ",") <> 0 Then
                descriptions = Split(.Range("J" & i).Value, ",")
              
                'XXX Moved active code inside If statement
                For Each item In descriptions
                    .Range("J" & i).Value = item
                    .Rows(i).Copy
                    .Rows(i).Insert
                Next item
                .Rows(i).EntireRow.Delete
            End If

        Next i
    End With
  
    With Worksheets("Clients")
        lastrow = .Range("J2").End(xlDown).Row
      
        For i = 2 To lastrow
            .Cells(i, "J").Value = Trim(.Cells(i, "J").Value)
        Next i
    End With

End Sub

My Dummy data in case it helps anyone else.

20211005 VBA Split and populate rows.xlsm
ABCDEFGHIJ
1Col1Col2Col3Col4Col5Col6Col7Col8Col9Col10
2222222222car, bus, train
3333333333
4444444444apple,orange,pear
5555555555Item 1, another item, one more item
Clients
 

ewarthur

New Member
Joined
Oct 5, 2021
Messages
2
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Try this:
Changes
1) xlDown won't work if you are expecting blanks in column J, changed to xlUp version
2) Your active code is outside the IF End If, moved inside the IF End If
3) Item was not defined, added Dim

VBA Code:
Sub ProcessCRMMod()

    Dim lastrow As Integer
    Dim i As Integer
    Dim descriptions() As String
    Dim item As Variant
 
    With Worksheets("Clients")
        'XXX Change from xlDown to xlUp
        lastrow = .Range("J" & Rows.Count).End(xlUp).Row
        For i = lastrow To 2 Step -1
            If InStr(1, .Range("J" & i).Value, ",") <> 0 Then
                descriptions = Split(.Range("J" & i).Value, ",")
             
                'XXX Moved active code inside If statement
                For Each item In descriptions
                    .Range("J" & i).Value = item
                    .Rows(i).Copy
                    .Rows(i).Insert
                Next item
                .Rows(i).EntireRow.Delete
            End If

        Next i
    End With
 
    With Worksheets("Clients")
        lastrow = .Range("J2").End(xlDown).Row
     
        For i = 2 To lastrow
            .Cells(i, "J").Value = Trim(.Cells(i, "J").Value)
        Next i
    End With

End Sub

My Dummy data in case it helps anyone else.

20211005 VBA Split and populate rows.xlsm
ABCDEFGHIJ
1Col1Col2Col3Col4Col5Col6Col7Col8Col9Col10
2222222222car, bus, train
3333333333
4444444444apple,orange,pear
5555555555Item 1, another item, one more item
Clients

Alex,

Thank you so much for giving me working code but also explaining why my version didn't give the results I hoped for.

Best Regards,

Eric
 

Forum statistics

Threads
1,147,962
Messages
5,744,051
Members
423,843
Latest member
alex2022

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
Top