Excel/VBA Breakdown field - vba

Question

Bit of a complicated task I have to do but I will try and explain. I have an excel file with 23000 lines of data which I am importing into a website. Each one has a field like so:
Category | other data | other data 2
Foods/Dog/Treats Pre-Pack | 1223 | image.jpg
I need it to grab each line and add a new line below it for each "/" so turning the above into:
Category | other data | other data 2
[blank in original line] | 1223 | image.jpg
Foods | [blank field] | [blank field]
Foods/Dog | [blank field] | [blank field]
Foods/Dog/Treats Pre-Pack | [blank field] | [blank field]
So the script needs to add a new line for each category but keeping the original category in front of it. So turning category/category2/category 3 into 4 lines of: [blank] - category - category/category2 - category/category2/category 3
Does anyone know a way or script to do this?
Thanks, Simon
Note: The worksheet is called "test" and the category column starts at E2 and goes to E23521
I have the following script:
Sub test()
Dim a, i As Long, ii As Long, e, n As Long
Dim b(), txt As String, x As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(5).Value))
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "/"
x = .Execute(txt).Count * 2
End With
ReDim b(1 To UBound(a, 1) + x, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
If a(i, 5) <> "" Then
For Each e In Split(a(i, 5), "/")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 5) = Trim$(e)
Next
End If
Next
.Resize(n).Value = b
End With
End Sub
This seems to create a new row as I need it to but does not keep the slash structuring moving up with each one. And also dosnt add a blank line on all the new ones and make the original category value blank.
SOLVED:
Sub splitEmUp()
Dim splitter() As String 'this is storage space for the split function
Dim i As Integer ' main-loop for counter "which cell we are on"
Dim j As Integer ' splitter for-loop counter "which section of the split are we on"
Range("E2").Activate 'starting in cell e2 because row 1 is headers and category is located in the B column
For i = 0 To 24000 'from beginning to end i=0 means e2, i=1 means e3
ActiveCell.Offset(i, 0).Value = Replace(ActiveCell.Offset(i, 0).Value, " / ", "!##")
splitter = Split(ActiveCell.Offset(i, 0), "/") 'split the cell based on / and store it in splitter
If (UBound(splitter)) > 0 Then 'if a split occurred
ActiveCell.Offset(i, 0).Value = "" 'set the activecell to blank
Debug.Print i
ActiveCell.Offset(i + 1, 0).EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove 'insert a new row and shift everything down
ActiveCell.Offset(i + 1, 0).Value = splitter(0) 'initialize the "Down" cells
ActiveCell.Offset(i + 1, 0).Value = Replace(ActiveCell.Offset(i + 1, 0).Value, "!##", " / ")
For j = 1 To UBound(splitter)
ActiveCell.Offset(i + j + 1).EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove 'create another row if it needs to
ActiveCell.Offset(i + (j + 1), 0).Value = ActiveCell.Offset(i + j).Value & "/" & splitter(j) 'fill out the new row
ActiveCell.Offset(i + (j + 1), 0).Value = Replace(ActiveCell.Offset(i + (j + 1), 0).Value, "!##", " / ")
Next
i = i + UBound(splitter) + 1 'need to step I past the new cells
ReDim splitter(0)
Erase splitter 'erase and eliminate splitter to avoid carry over.
End If
Next
End Sub

Answer 1

This is what I came up with. Be sure to change the sheet names to fit your workbook. Also be sure to change the input range to fit your own input range of cells.
Function SplitAndWrite(inputCell As Range, TopOfOutputRange As Range, sep As String) As Range
Dim texts() As String, i As Integer, outputText As String
texts = Split(inputCell.Value, sep)
outputText = ""
TopOfOutputRange = "" 'your blank line
For i = LBound(texts) To UBound(texts)
outputText = outputText & sep & texts(i)
TopOfOutputRange.Offset(i + 1) = outputText
Next i
Set SplitAndWrite = TopOfOutputRange.Offset(UBound(texts) + 1)
End Function
Sub THEPOPULATOR()
Dim s3 As Worksheet, s4 As Worksheet
Set s3 = Sheets("Sheet1")
Set s4 = Sheets("Sheet2")
Dim inputrange As Range, c As Range, outputrange As Range
Set outputrange = s4.Range("A1")
Set inputrange = s3.Range(s3.Cells(2, 1), s3.Cells(2, 1).End(xlDown)) 'cells(2,1) = "A1". change this to your top input cell. then the second half will find the bottom cell on its own. This is the same as pressing Ctrl+down
For Each c In inputrange
s3.Range(c.Offset(0, 1), c.Offset(0, c.End(xlToRight).Column)).Copy outputrange.Offset(1, 1)
Set outputrange = SplitAndWrite(c, outputrange.Offset(1), "/")
Next c
End Sub

Answer 2

Here is an example from another solution How to split cell in a row with Excel, which I modified just a tiny bit to fit your situation:
Public Sub solutionJook()
Dim arr() As Variant
Dim arrSum() As Variant
Dim arrResult() As Variant
Dim arrTemp As Variant
Dim i As Long
Dim j As Long
Dim h As Long
Dim lngSplitColumn As Long
'input of array to seperate -> should cover all columns+rows of your data
arr = Range("A1:C2")
'specify which column has the values to be split up -> here this is the category column
lngSplitColumn = 2
'using the boundries of the given range,
'arrSum has now always the right boundries for the first dimension
ReDim Preserve arrSum(LBound(arr, 2) To UBound(arr, 2), 1 To 1)
'create the array with seperated A B C
For i = LBound(arr, 1) To UBound(arr, 1)
'use split to make Foods/Dog/Treats Pre-Pack into an array, using '\' (chr(92)) as indicator
arrTemp = Split(arr(i, lngSplitColumn), Chr(92))
'every value of arrTemp creates a new row
For j = LBound(arrTemp) To UBound(arrTemp)
'loop through all input columns and create the new row
For h = LBound(arr, 2) To UBound(arr, 2)
If h = lngSplitColumn Then
'setup the value of the splitted column
Dim k as long
arrSum(h, UBound(arrSum, 2)) = arrTemp(LBound(arrTemp))
for k = LBound(arrTemp)+1 to j
arrSum(h, UBound(arrSum, 2)) = arrSum(h, UBound(arrSum, 2)) & "\" & arrTemp(k) 'set Foods Foods/Dog Foods/Dog/Treats Pre-Pack
next k
Else
'setup the value of any other column
arrSum(h, UBound(arrSum, 2)) = arr(i, h) 'set Value of Column h
End If
Next h
ReDim Preserve arrSum(LBound(arr, 1) To UBound(arr, 2), _
LBound(arrSum, 2) To (UBound(arrSum, 2) + 1))
Next j
Next i
'clean up last empty row (not realy necessary)
ReDim Preserve arrSum(LBound(arr, 1) To UBound(arr, 2), _
LBound(arrSum, 2) To (UBound(arrSum, 2) - 1))
'setup transposed result array
ReDim arrResult(LBound(arrSum, 2) To UBound(arrSum, 2), _
LBound(arrSum, 1) To UBound(arrSum, 1))
'transpose the array
For i = LBound(arrResult, 1) To UBound(arrResult, 1)
For j = LBound(arrResult, 2) To UBound(arrResult, 2)
arrResult(i, j) = arrSum(j, i)
Next j
Next i
'specify target range
Range(Cells(1, 5), Cells(UBound(arrResult, 1), 4 + UBound(arrResult, 2))) = arrResult
End Sub
You might need to adapt the target range however.
Cells(1,5) -> E1 is the starting point of pasting