VBA to Split and fill

[NeoSez]

I am trying to figure out how to separate column D into separate cells in the same column just below the current row.
So, 001 Street will have a new row just below this one.
002 Street will have a new row just below this one.
003 Street will have a new row just below this one.
etcera
It should copy the preceding information with it.

tiles	12x24	10	001 street 002 street 003 street 008 street 112 street 222 street 234 street 456 street 666 street 777 street
ladders	30'	2	898 street 929 street
doors	35x88	3	555 street 666 street 777 street

The new chart will look something like this:
I hope this all makes sense.

tiles	12x24	10	001 street
tiles	12x24	10	002 street
tiles	12x24	10	003 street

 

[myall_blues]

Try this:

Sub DataSplit()
    Dim i As Long, lastRow As Long
    Dim s
    With Sheets("Sheet1")   '<-- Change the sheet name to whatever you need it to be
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = lastRow To 1 Step -1  '<-- Change the 1 to whatever the first row of your data is
            If InStr(.Cells(i, 4), vbLf) Then
                s = Split(.Cells(i, 4), vbLf)
                .Rows(i + 1).Resize(UBound(s)).Insert
                .Cells(i + 1, 1).Resize(UBound(s), 4).Value = .Cells(i, 1).Resize(, 4).Value
                .Cells(i, 4).Resize(UBound(s) + 1) = Application.Transpose(s)
            End If
        Next i
    End With
End Sub

 

[Alex Blakenburg]

If you have a lot of data this might be quicker.
(PS: Have you considered using Power Query ?)

Sub DataSplit_array()
    Dim sht As Worksheet
    Dim rng As Range
    Dim arrSrc As Variant, arrOut As Variant
    Dim lastRow As Long
    Dim splitCell As Variant
    Dim maxLines As Long
    Dim i As Long, j As Long, iCol As Long, rowOut As Long
   
    Set sht = Worksheets("Sheet1")                          '<-- Change the sheet name to whatever you need it to be
    With sht
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range(.Cells(1, 1), .Cells(lastRow, 4))  '<-- If there is a heading change it to .Cells(2,1)
        arrSrc = rng.Value
    End With
   
    ' Based on the nunber of Line Feeds get the count to dimension the output array
    For i = 1 To UBound(arrSrc)
        maxLines = maxLines + (Len(arrSrc(i, 4)) - Len(Replace(arrSrc(i, 4), vbLf, "")) + 1)
    Next i
   
    ReDim arrOut(1 To maxLines, 1 To UBound(arrSrc, 2))
   
    For i = 1 To UBound(arrSrc)
        splitCell = Split(arrSrc(i, 4), vbLf)
        For j = LBound(splitCell) To UBound(splitCell)
            rowOut = rowOut + 1
            arrOut(rowOut, 1) = arrSrc(i, 1)
            arrOut(rowOut, 2) = arrSrc(i, 2)
            arrOut(rowOut, 3) = arrSrc(i, 3)
            arrOut(rowOut, 4) = splitCell(j)
        Next j
    Next i
   
    rng.Resize(rowOut, UBound(arrOut, 2)).Value = arrOut
End Sub

 

[NeoSez]

Try this:

Sub DataSplit()
    Dim i As Long, lastRow As Long
    Dim s
    With Sheets("Sheet1")   '<-- Change the sheet name to whatever you need it to be
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = lastRow To 1 Step -1  '<-- Change the 1 to whatever the first row of your data is
            If InStr(.Cells(i, 4), vbLf) Then
                s = Split(.Cells(i, 4), vbLf)
                .Rows(i + 1).Resize(UBound(s)).Insert
                .Cells(i + 1, 1).Resize(UBound(s), 4).Value = .Cells(i, 1).Resize(, 4).Value
                .Cells(i, 4).Resize(UBound(s) + 1) = Application.Transpose(s)
            End If
        Next i
    End With
End Sub

myall_blues Thank you. I am going to try this on a smaller sheet. I want to ensure I understand this. Making changes to the column from 4 (D) to 19 (S). Just wondering if this is correct below:

[/B][/HEADING]
Sub DataSplit()
    Dim i As Long, lastRow As Long
    Dim s
    With Sheets("Sheet1")   '<-- Change the sheet name to whatever you need it to be
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = lastRow To [COLOR=rgb(184, 49, 47)]4[/COLOR] Step -[COLOR=rgb(184, 49, 47)]4[/COLOR]  '<-- [B][COLOR=rgb(184, 49, 47)]Change the 1[/COLOR][/B] to whatever the first row of your data is
            If InStr(.Cells(i, 4), vbLf) Then
                s = Split(.Cells(i, [COLOR=rgb(184, 49, 47)]19[/COLOR]), vbLf)
                .Rows(i + 1).Resize(UBound(s)).Insert
                .Cells(i + 1, 1).Resize(UBound(s), [COLOR=rgb(184, 49, 47)]19[/COLOR]).Value = .Cells(i, 1).Resize(, [COLOR=rgb(184, 49, 47)]19[/COLOR]).Value
                .Cells(i, [COLOR=rgb(184, 49, 47)]19[/COLOR]).Resize(UBound(s) + 1) = Application.Transpose(s)
            End If
        Next i
    End With
End Sub
[HEADING=3][B]

​

 

[NeoSez]

If you have a lot of data this might be quicker.
(PS: Have you considered using Power Query ?)

Sub DataSplit_array()
    Dim sht As Worksheet
    Dim rng As Range
    Dim arrSrc As Variant, arrOut As Variant
    Dim lastRow As Long
    Dim splitCell As Variant
    Dim maxLines As Long
    Dim i As Long, j As Long, iCol As Long, rowOut As Long
  
    Set sht = Worksheets("Sheet1")                          '<-- Change the sheet name to whatever you need it to be
    With sht
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range(.Cells(1, 1), .Cells(lastRow, 4))  '<-- If there is a heading change it to .Cells(2,1)
        arrSrc = rng.Value
    End With
  
    ' Based on the nunber of Line Feeds get the count to dimension the output array
    For i = 1 To UBound(arrSrc)
        maxLines = maxLines + (Len(arrSrc(i, 4)) - Len(Replace(arrSrc(i, 4), vbLf, "")) + 1)
    Next i
  
    ReDim arrOut(1 To maxLines, 1 To UBound(arrSrc, 2))
  
    For i = 1 To UBound(arrSrc)
        splitCell = Split(arrSrc(i, 4), vbLf)
        For j = LBound(splitCell) To UBound(splitCell)
            rowOut = rowOut + 1
            arrOut(rowOut, 1) = arrSrc(i, 1)
            arrOut(rowOut, 2) = arrSrc(i, 2)
            arrOut(rowOut, 3) = arrSrc(i, 3)
            arrOut(rowOut, 4) = splitCell(j)
        Next j
    Next i
  
    rng.Resize(rowOut, UBound(arrOut, 2)).Value = arrOut
End Sub

Alex Blakenburg Thank you for this code. I want to ensure I understand this. Making changes to the column from 4 (D) to 19 (S). Just wondering if this is correct below:​

[/B]
Sub DataSplit_array()
    Dim sht As Worksheet
    Dim rng As Range
    Dim arrSrc As Variant, arrOut As Variant
    Dim lastRow As Long
    Dim splitCell As Variant
    Dim maxLines As Long
    Dim i As Long, j As Long, iCol As Long, rowOut As Long
  
    Set sht = Worksheets("Sheet1")                          '<-- Change the sheet name to whatever you need it to be
    With sht
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range(.Cells(4, 1), .Cells(lastRow, 19))  '<-- If there is a heading change it to .Cells(2,1)
        arrSrc = rng.Value
    End With
  
    ' Based on the nunber of Line Feeds get the count to dimension the output array
    For i = 1 To UBound(arrSrc)
        maxLines = maxLines + (Len(arrSrc(i, 19)) - Len(Replace(arrSrc(i, 19), vbLf, "")) + 1)
    Next i
  
    ReDim arrOut(1 To maxLines, 1 To UBound(arrSrc, 2))
  
    For i = 1 To UBound(arrSrc)
        splitCell = Split(arrSrc(i, 19), vbLf)
        For j = LBound(splitCell) To UBound(splitCell)
            rowOut = rowOut + 1
            arrOut(rowOut, 1) = arrSrc(i, 1)
            arrOut(rowOut, 2) = arrSrc(i, 2)
            arrOut(rowOut, 3) = arrSrc(i, 3)
arrOut(rowOut, 4) = arrSrc(i, 4)
arrOut(rowOut, 5) = arrSrc(i, 5)
arrOut(rowOut, 6) = arrSrc(i, 6)
arrOut(rowOut, 7) = arrSrc(i, 7)
arrOut(rowOut, 8) = arrSrc(i, 8)
arrOut(rowOut, 9) = arrSrc(i, 9)
arrOut(rowOut, 10) = arrSrc(i, 10)
arrOut(rowOut, 11) = arrSrc(i, 11)
arrOut(rowOut, 12) = arrSrc(i, 12)
arrOut(rowOut, 13) = arrSrc(i, 13)
arrOut(rowOut, 14) = arrSrc(i, 14)
arrOut(rowOut, 15) = arrSrc(i,15)
arrOut(rowOut, 16) = arrSrc(i, 16)
arrOut(rowOut, 17) = arrSrc(i, 17)
arrOut(rowOut, 18) = arrSrc(i, 18)
            arrOut(rowOut, 19) = splitCell(j)
        Next j
    Next i
  
    rng.Resize(rowOut, UBound(arrOut, 2)).Value = arrOut
End Sub
[B]

 

[myall_blues]

Almost. These two lines are not correct - they should be as follows.

For i = lastRow To 4 Step -1  
            If InStr(.Cells(i, 19), vbLf) Then

 

[NeoSez]

Almost. These two lines are not correct - they should be as follows.

For i = lastRow To 4 Step -1
            If InStr(.Cells(i, 19), vbLf) Then

Thank you for making the correction.
I just tried and it wouldn't work. It came back with an error:
"Run-time error '1004':
Application-defined or object-defined error."
Could the reason be, that there are more columns after column 19 (S)? It goes all the way to Z.

Sub DataSplit()
    Dim i As Long, lastRow As Long
    Dim s
    With Sheets("Sheet1")   '<-- Change the sheet name to whatever you need it to be
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = lastRow To 4 Step -1  '<-- Change the 1 to whatever the first row of your data is
            If InStr(.Cells(i, 4), vbLf) Then
                s = Split(.Cells(i, 19), vbLf)
                .Rows(i + 1).Resize(UBound(s)).Insert
                .Cells(i + 1, 1).Resize(UBound(s), 19).Value = .Cells(i, 1).Resize(, 19).Value
                .Cells(i, 19).Resize(UBound(s) + 1) = Application.Transpose(s)
            End If
        Next i
    End With
End Sub

 

[Alex Blakenburg]

You did a great job on the conversion. You can replace the repetitive section with the code below (I knew there was a reason I had declared iCol )

However this statement changes everything and you really need to provide a "representative" example up front.

Could the reason be, that there are more columns after column 19 (S)? It goes all the way to Z.

1) where do you want the data in column T to Z to appear in the output ?
ie only on the first line OR repeating on each line as for columns A-R
2) do any of the columns contain formulas ?


Replacing repetitive data with a loop.

    For i = 1 To UBound(arrSrc)
        splitCell = Split(arrSrc(i, 19), vbLf)
        For j = LBound(splitCell) To UBound(splitCell)
            rowOut = rowOut + 1
            For iCol = 1 To UBound(arrSrc, 2) - 1
                arrOut(rowOut, iCol) = arrSrc(i, iCol)
            Next iCol
            arrOut(rowOut, 19) = splitCell(j)
        Next j
    Next i

 

[Alex Blakenburg]

I just tried and it wouldn't work. It came back with an error:
"Run-time error '1004':
Application-defined or object-defined error."

I can't reproduce your error with @myall_blues's code and you also didn't tell us what line it producing the error.
I can see that you only implemented one of the 2 changes myall suggested.
You haven't changed this line to be 19.

            If InStr(.Cells(i, 19), vbLf) Then

Try that first and if you still get the error then on what line of the code are you getting it.
Also when you look at the output that code outputs as it goes so on what line does the output stop ?

 

[NeoSez]

You did a great job on the conversion. You can replace the repetitive section with the code below (I knew there was a reason I had declared iCol )

However this statement changes everything and you really need to provide a "representative" example up front.

1) where do you want the data in column T to Z to appear in the output ?
ie only on the first line OR repeating on each line as for columns A-R
2) do any of the columns contain formulas ?


Replacing repetitive data with a loop.

    For i = 1 To UBound(arrSrc)
        splitCell = Split(arrSrc(i, 19), vbLf)
        For j = LBound(splitCell) To UBound(splitCell)
            rowOut = rowOut + 1
            For iCol = 1 To UBound(arrSrc, 2) - 1
                arrOut(rowOut, iCol) = arrSrc(i, iCol)
            Next iCol
            arrOut(rowOut, 19) = splitCell(j)
        Next j
    Next i

Thanks Alex.
1) where do you want the data in column T to Z to appear in the output ?
ie only on the first line OR repeating on each line as for columns A-R
ANSWER: repeating on each line as for columns A-R
2) do any of the columns contain formulas ?
ANSWER: Yes, T, U, and X have formulas.

Thank you for replacing the repetitive loop.
Is this what the script should look like after replacement?

Sub DataSplit_array()
    Dim sht As Worksheet
    Dim rng As Range
    Dim arrSrc As Variant, arrOut As Variant
    Dim lastRow As Long
    Dim splitCell As Variant
    Dim maxLines As Long
    Dim i As Long, j As Long, iCol As Long, rowOut As Long
  
    Set sht = Worksheets("Sheet1")                          '<-- Change the sheet name to whatever you need it to be
    With sht
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = .Range(.Cells(4, 1), .Cells(lastRow, 19))  '<-- If there is a heading change it to .Cells(2,1)
        arrSrc = rng.Value
    End With
  
    ' Based on the nunber of Line Feeds get the count to dimension the output array
    For i = 1 To UBound(arrSrc)
        splitCell = Split(arrSrc(i, 19), vbLf)
        For j = LBound(splitCell) To UBound(splitCell)
            rowOut = rowOut + 1
            For iCol = 1 To UBound(arrSrc, 2) - 1
                arrOut(rowOut, iCol) = arrSrc(i, iCol)
            Next iCol
            arrOut(rowOut, 19) = splitCell(j)
        Next j
    Next i
  
    rng.Resize(rowOut, UBound(arrOut, 2)).Value = arrOut
End Sub