VBA Question | Insert rows and split cells based on line count in a cell

[dutch245]

Good morning!

I have a data set that comprises one record per row in excel, however the cells in columns M and N may be one line of data, or may grow into several lines of data.

For the rows that have multiple lines of data in cells M and N I have been manually going in and adding blank rows to equal the number of lines in cells M and N - copying the data from columns A through L into the blank rows, and finally splitting the lines in cells M and N into all of the rows I've inserted.

I have found information online to:

• Get count of lines in a cell
• Insert blank rows into my data set

I'm looking to know if anyone knows of a guide, or can provide the VBA code to search my range of data for rows with multiple line cells M and N, insert blank rows as needed, copy cells A thru L into the blank rows, then split M and N accordingly?

Hopefully this post is clear enough to understand, if not please let me know!

Thank you,

 

[sijpie]

I am assuming that the multiple lines in M & N are because of a hard return in the cell, not because of line wrapping. is that correct?

 

[sijpie]

What if M and N both have multiple lines in one row? Doe s the output 1st row contain the first line of M and the first line of N, 2nd row contain the 2nd line of M and 2nd line of N?

 

[dutch245]

That is correct. I tried a VBA code that I can't remember that did what I was looking for - only not with a column range.

 

[dutch245]

M and N have both have multiple lines in one row, and yes to your second question. M is a task and N is a name for that task.

 

[sijpie]

Option Explicit

Sub SplitTable()
'/////////////////////////////////////////////////////////////////// _
 // Split lines in column M and N into nnew rows, copying the row // _
 // columns A-L into the additional rows.                         // _
 ///////////////////////////////////////////////////////////////////
 
    Dim vInp As Variant, vOutp As Variant
    Dim lRi As Long, lRo As Long, lC As Long, lRCount As Long, lC2 As Long
    Dim UB1 As Long, UB2 As Long
    Dim i As Integer, m As Integer, n As Integer, k As Integer
    Dim wsThis As Worksheet, wsOutp As Worksheet
    
    Const sStartCellAddress = "A5" '<<<<<< Modify top left corner of range
    
    
    Set wsThis = ActiveSheet
    
    'Get the input table into a variant array for very fast processing
    vInp = wsThis.Range(sStartCellAddress).CurrentRegion.Value
    'get the size of the input array
    UB1 = UBound(vInp, 1)   'number of rows
    UB2 = UBound(vInp, 2)   'number of columns
    
    'Check array is correct (goes to column N)
    If UB2 < 14 Then
        MsgBox "Range starting in " & sStartCellAddress & " does not seem right size"
        Exit Sub
    End If
    
    'Count the number of rows to be added by counting the nuber of return symbols in M & N
    For lRi = 1 To UB1
        Do
            ' Search in cell in column M
            i = InStr(i + 1, vInp(lRi, 13), vbLf) 'vbLF is linefeed (ASCII 10)
            m = m + 1
        Loop While i > 0
        Do
            ' Search in cell in column N
            i = InStr(i + 1, vInp(lRi, 14), vbLf)  'vbLF is linefeed (ASCII 10)
            n = n + 1
        Loop While i > 0
        
        'add the largest of the two to the additional linecount
        lRCount = lRCount + IIf(n > m, n, m)
        'Reset counters
        m = 0: n = 0
    Next lRi
    
    'lRcount now holds the number of lines we need to add
    ' Create output array
    ReDim vOutp(1 To UB1 + lRCount, 1 To UB2)
    
    
    'Now copy values from input to output
    lRo = 1: i = 0
    For lRi = 1 To UB1
        For lC = 1 To UB2
            If lC = 13 Then 'column M
                i = 0
                Do
                    ' Search in cell in column M
                    k = i
                    i = InStr(i + 1, vInp(lRi, lC), vbLf)
                    ' copy each split line into new row
                    vOutp(lRo + m, lC) = Mid(vInp(lRi, lC), k + 1, IIf(i, i - k - 1, Len(vInp(lRi, lC)) - k))
                    m = m + 1
                Loop While i > 0
                lC = lC + 1 ' Now do column N
                Do
                    ' Search in cell in column N
                    k = i
                    i = InStr(i + 1, vInp(lRi, lC), vbLf)
                    vOutp(lRo + n, lC) = Mid(vInp(lRi, lC), k + 1, IIf(i, i - k - 1, Len(vInp(lRi, lC)) - k))
                     n = n + 1
                Loop While i > 0
                ' Now copy Cols A-L inot the new rows
                k = IIf(n > m, n, m)
                For i = 1 To k
                    For lC2 = 1 To 12
                        vOutp(lRo + i, lC2) = vInp(lRi, lC2)
                    Next lC2
                Next i
                m = 0: n = 0
                lRo = lRo + k
            Else            'columns A-L and possibly columns past N, just copy
                vOutp(lRo, lC) = vInp(lRi, lC)
            End If
        Next lC
    Next lRi
    
    ' Nou output onto new sheet
    Set wsOutp = Sheets.Add(after:=wsThis)
    wsOutp.Range(sStartCellAddress).Resize(UB1 + lRCount, UB2).Value = vOutp
    
End Sub

 

[dutch245]

This is perfect, thank you!

 

[sijpie]

Good. I don't know how large your range is. I did it using arrays which work really fast even for very large tables, but the code is often a bit more difficult to follow.

 

[dutch245]

They shouldn't grow past 500 rows, so it shouldn't be all that bad.

I've added into my 'Frankenstein' code - moved onto something else now.

Unless I need to start a separate thread, would you know how to help with this?

I'm using this line in VBA to rename my current sheet to today's date, eg. 07.01 for today.

ActiveSheet.Name = Replace(Format(Now, "mm.dd"), ":", "|")

Do you know how I could add the string "DJL | " before the date?

Thanks!

 

[dutch245]

Nevermind, I sorted it out!

Sub RenameSheet()    Dim X As Variant
    
  ActiveSheet.Name = Replace(Format(Now, "mm.dd"), ":", "|")
  X = ActiveSheet.Name
  ActiveSheet.Name = "DJL | " & X
  
End Sub

Thanks!