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

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