VBA script to count string, insert rows, copy row, split cell

Question

The department that provides me a spreadsheet to be used in my database now includes multiple text in a cell. In order to link to that data I have to turn it into multiple rows. Example: LC123/LC463/LC9846 needs to have the entire row copied with just one "LC" string in each row- cell1 cell2 LC123 cell1 cell2 LC463 cell1 cell2 LC9846

I tried these two subroutines but obviously it failed

Sub InSert_Row()
Dim j As Long
j = InputBox(=SUM(LEN(ActiveCell)-LEN(SUBSTITUTE(ActiveCell,"LC",""))-1)
ActiveCell.EntireRow.Copy
ActiveCell.Offset(j).EntireRow.Insert Shift:=xlDown
End Sub

Sub SplitAndTranspose()
Dim N() As String
N = Split(ActiveCell, Chr(10))
ActiveCell.Resize(UBound(N) + 1) = WorksheetFunction.Transpose(N)
End Sub

The 2nd subroutine will split and copy but it doesn't insert rows, it writes over the rows below it.

Answer 1

'In memory' method

Inserting rows as necessary would be perhaps the most simple to understand, but the performance of making thousands of seperate row inserts would not be good. This would be fine for a one off (perhaps you only need a one-off) and should only take a minute or two to run but I thought what the heck and so wrote an approach that splits the data in memory using a collection and arrays. It will run in the order of seconds.

I have commented what it is doing.

Sub ProcessData()
    Dim c As Collection
    Dim arr, recordVector
    Dim i As Long, j As Long
    Dim rng As Range
    Dim part, parts

    'replace with your code to assign the right range etc
    Set rng = ActiveSheet.UsedRange
    j = 3 'replace with right column index, or work it out using Range.Find etc

    arr = rng.Value 'load the data

    'Process the data adding additional rows etc
    Set c = New Collection
    For i = 1 To UBound(arr, 1)
        parts = Split(arr(i, j), "/") 'split the data based on "/"
        For Each part In parts 'loop through each "LC" thing
            recordVector = getVector(arr, i) 'get the row data
            recordVector(j) = part 'replace the "LC" thing
            c.Add recordVector 'add it to our results collection
        Next part
    Next i

    'Prepare to dump the data back to the worksheet
    rng.Clear

    With rng.Parent
        .Range( _
            rng.Cells(1, 1), _
            rng.Cells(1, 1).Offset(c.Count - 1, UBound(arr, 2) - 1)) _
            .Value = getCollectionOfVectorsToArray(c)
    End With

End Sub

'Helper method to return a vector representing our row data
Private Function getVector(dataArray, dataRecordIndex As Long)
    Dim j As Long, tmpArr
    ReDim tmpArr(LBound(dataArray, 2) To UBound(dataArray, 2))
    For j = LBound(tmpArr) To UBound(tmpArr)
        tmpArr(j) = dataArray(dataRecordIndex, j)
    Next j
    getVector = tmpArr
End Function
'Helper method to return an array from a collection of vectors
Function getCollectionOfVectorsToArray(c As Collection)
    Dim i As Long, j As Long, arr
    ReDim arr(1 To c.Count, LBound(c(1), 1) To UBound(c(1), 1))
    For i = 1 To c.Count
        For j = LBound(arr, 2) To UBound(arr, 2)
            arr(i, j) = c(i)(j)
        Next j
    Next i
    getCollectionOfVectorsToArray = arr
End Function

Edit:

Alternative "Range Insert" method.

It will be slower (although I made the number of discrete insert and copy operations be based on original row count, not some recursive sweep so it is not too bad) but is simpler to understand and so to perhaps tweak if needed. It should run in the order of a couple of minutes.

Sub ProcessData_RangeMethod()
    Dim rng As Range
    Dim colIndex As Long
    Dim parts
    Dim currRowIndex As Long

    'replace with your code to assign the right range etc
    Set rng = ActiveSheet.UsedRange

    colIndex = 3 'replace with right column index, or work it out using Range.Find etc

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    currRowIndex = 1
    Do Until currRowIndex > rng.Rows.Count
        parts = Split(rng.Cells(currRowIndex, colIndex), "/")
        If UBound(parts) > 0 Then
            rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count)).Insert xlShiftDown
            rng.Rows(currRowIndex).Copy rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count))
            rng.Range(rng.Cells(currRowIndex, colIndex), rng.Cells(currRowIndex + UBound(parts), colIndex)).Value = Application.Transpose(parts)
        End If
        currRowIndex = currRowIndex + 1 + UBound(parts)
    Loop

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub