Split rows - varies

[MelanieB]

I need to split a lot of rows in a worksheet.
Sample row attached.

I want to split this row into 3 rows, so that each line item in column C is on its own row. I can do this manually, but I have 165 rows and they all vary from having 3 lines (like the sample) to some having up to 15 lines.

Every line in Column C has a corresponding number of lines in Columns D, E and F and they are all the same number of lines.

Any ideas on how I can this more efficiently than manually adding rows?

Image A.jpg

[HansV]

Do you want to repeat the values of columns A and B in each new row?

[MelanieB]

Yes, ideally I would like that

[HansV]

Run this macro:

Code: Select all

Sub SplitLines()
    Const FirstRow = 2
    Dim LastRow As Long
    Dim r As Long
    Dim CLines() As String
    Dim DLines() As String
    Dim ELines() As String
    Dim FLines() As String
    Dim i As Long
    Dim n As Long
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For r = LastRow To FirstRow Step -1
        CLines = Split(Cells(r, 3).Value, vbLf)
        n = UBound(CLines)
        If n > 0 Then
            DLines = Split(Cells(r, 4).Value, vbLf)
            ELines = Split(Cells(r, 5).Value, vbLf)
            FLines = Split(Cells(r, 6).Value, vbLf)
            For i = n To 1 Step -1
                Cells(r + 1, 1).EntireRow.Insert
                Cells(r + 1, 1).Value = Cells(r, 1).Value
                Cells(r + 1, 2).Value = Cells(r, 2).Value
                Cells(r + 1, 3).Value = CLines(i)
                Cells(r + 1, 4).Value = DLines(i)
                Cells(r + 1, 5).Value = ELines(i)
                Cells(r + 1, 6).Value = FLines(i)
            Next i
            Cells(r, 3).Value = CLines(0)
            Cells(r, 4).Value = DLines(0)
            Cells(r, 5).Value = ELines(0)
            Cells(r, 6).Value = FLines(0)
        End If
    Next r
    Application.ScreenUpdating = True
End Sub

[MelanieB]

I'm getting a run time error '9'
Subscript out of range

Debug shows it stops at Cells(r + 1, 5).Value = ELines(i)

Do you want me to send you a copy of the worksheet separately (privately)?

[HansV]

Yes please. My email address is hans dot vogelaar at gmail dot com

[HansV]

In the workbook that you sent me, the number of lines varies within a row. For example, this is the number of lines in columns E to H in the first few rows:

S2435.png

This means that it is impossible to match lines to the correct rows.

[MelanieB]

hmmm. The person who sent this told me she pressed Alt+Enter at the end of every line, but after you pointed that out, and it looks like she did not. So Ok. Well thanks for looking at it for me. At least I can stop trying to figure ways around doing it manually and just get to doing it.

As always, Hans, you are a treasure. Thank you!

[HansV]

It would be possible to split the rows, but then you'd have to follow it up with a visual check and manually move lines that ended up incorrectly.
Let me know if you want that.

[HansV]

Here is a macro that will split the rows, requiring manual corrections afterwards:

Code: Select all

Sub SplitLines()
    Const FirstRow = 2
    Dim LastRow As Long
    Dim r As Long
    Dim ELines() As String
    Dim FLines() As String
    Dim GLines() As String
    Dim HLines() As String
    Dim i As Long
    Dim nE As Long
    Dim nF As Long
    Dim nG As Long
    Dim nH As Long
    Dim n As Long
    Application.ScreenUpdating = False
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    For r = LastRow To FirstRow Step -1
        ELines = Split(Cells(r, 5).Value, vbLf)
        FLines = Split(Cells(r, 6).Value, vbLf)
        GLines = Split(Cells(r, 7).Value, vbLf)
        HLines = Split(Cells(r, 8).Value, vbLf)
        nE = UBound(ELines)
        nF = UBound(FLines)
        nG = UBound(GLines)
        nH = UBound(HLines)
        n = Application.Max(nE, nF, nG, nH)
        If n > 0 Then
            For i = n To 1 Step -1
                Cells(r + 1, 1).EntireRow.Insert
                Cells(r + 1, 1).Value = Cells(r, 1).Value
                Cells(r + 1, 2).Value = Cells(r, 2).Value
                Cells(r + 1, 3).Value = Cells(r, 3).Value
                Cells(r + 1, 4).Value = Cells(r, 4).Value
                If i <= nE Then Cells(r + 1, 5).Value = ELines(i)
                If i <= nF Then Cells(r + 1, 6).Value = FLines(i)
                If i <= nG Then Cells(r + 1, 7).Value = GLines(i)
                If i <= nH Then Cells(r + 1, 8).Value = HLines(i)
                Cells(r + 1, 9).Value = Cells(r, 9).Value
            Next i
            Cells(r, 5).Value = ELines(0)
            Cells(r, 6).Value = FLines(0)
            Cells(r, 7).Value = GLines(0)
            Cells(r, 8).Value = HLines(0)
        End If
        
    Next r
    Application.ScreenUpdating = True
End Sub

[HansV]

My previous reply contained a typo, it has now been corrected.

[snb]

Alternative:

Code: Select all

Sub M_snb()
  sn = Cells(1).CurrentRegion
  
  With CreateObject("scripting.dictionary")
     For j = 1 To UBound(sn)
       sp = Array(Split(sn(j, 5), vbLf), Split(sn(j, 6), vbLf), Split(sn(j, 7), vbLf), Split(sn(j, 8), vbLf))
       y = Application.Max(UBound(sp(0)), UBound(sp(1)), UBound(sp(2)), UBound(sp(3)))
       
       For jj = 0 To y
         If jj > UBound(sp(0)) Then c00 = "" Else c00 = sp(0)(jj)
         If jj > UBound(sp(1)) Then c01 = "" Else c01 = sp(1)(jj)
         If jj > UBound(sp(2)) Then c02 = "" Else c02 = sp(2)(jj)
         If jj > UBound(sp(3)) Then c03 = "" Else c03 = sp(3)(jj)
         .Item(.Count) = Array(sn(j, 1), sn(j, 2), sn(j, 3), sn(j, 4), sn(j, 5), c00, c01, c02, c03)
       Next
     Next
     
     Cells(1, 10).Resize(.Count, UBound(sn, 2)) = Application.Index(.items, 0, 0)
  End With
End Sub

[hamster]

my 3 cents with Power Query

Code: Select all

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    TFC = Table.AddColumn(Source, "Exp", each Table.FromColumns({Text.Split([Column3],"#(lf)"),Text.Split([Column4],"#(lf)"),Text.Split([Column5],"#(lf)"),Text.Split([Column6],"#(lf)")})),
    TSC = Table.SelectColumns(TFC,{"Column1", "Column2", "Exp"}),
    Exp = Table.ExpandTableColumn(TSC, "Exp", {"Column1", "Column2", "Column3", "Column4"}, {"Exp.Column1", "Exp.Column2", "Exp.Column3", "Exp.Column4"})
in
    Exp

example attached