Using VBA to separate and stack data from an Excel Cell

Question

I have an excel file where all the data is dumped into 4 cells. Column A has a header and then 4 start times (which will be the same every time) and column B has a header and then 4 cells each of which will contain a different number of email addresses and other details every day so the VBA has to work no matter the density of the cells in column B.

What I want to achieve is neatly stacked rows of data one for each email address no matter the number of addresses in the cell on a given day. The Data is formatted with the row breaks separated by ; and the column breaks separated by , so

Jeffsmith@gmail.com,Jeff Smith,555-4196;BobJones@Gmail.com,Bob Jones,555-3827 (all in B2)

needs to become

Jeffsmith@gmail.com (column break) Jeff Smith (column break) 555-4196

(row break)

BobJones@Gmail.com (column break) Bob Jones (column break) 555-3827

and so on for each cell So far I have tried using inserts with the following code

RowNum1 = (Len(Range("B2")) - Len(Replace(Range("B2"), "@", "")))
RowNum2 = (Len(Range("B3")) - Len(Replace(Range("B3"), "@", "")))
RowNum3 = (Len(Range("B4")) - Len(Replace(Range("B4"), "@", "")))
RowNum4 = (Len(Range("B5")) - Len(Replace(Range("B5"), "@", "")))

If RowNum1 <> 0 Then
Rows("3:" & 1 + RowNum1).EntireRow.Insert
End If

If RowNum2 <> 0 Then
Rows(3 + RowNum1 & ":" & 1 + RowNum1 + RowNum2).EntireRow.Insert
End If

If RowNum3 <> 0 Then
Rows(3 + RowNum1 + RowNum2 & ":" & 2 + RowNum1 + RowNum2 + RowNum3).EntireRow.Insert
End If

and that seems to put the correct row breaks into the data (I'm not 100% on this) but I'm stumped when it comes to separating the data and putting it where it needs to be. Any help would be greatly appreciated.

Answer 1

I didn't bother with the dates. But this will split Range B2 for you.

Sub ExplodeB2()
    Const SampleString = "Jeffsmith@gmail.com,Jeff Smith,555-4196;BobJones@Gmail.com,Bob Jones,555-3827 (all in B2)"
    Dim x As Long
    Dim arrRows

    arrRows = Split(Range("B2").Value, ";")

    For x = 0 To UBound(arrRows)

        Cells(x + 2, 2).Resize(1, 3) = Split(arrRows(x), ",")

    Next

End Sub

Before and After

Answer 2

For multiple cells, you can join the cell values to one string before you split them:

Set rangeFrom = [B2:B5]
Set rangeTo = [D2]

a = WorksheetFunction.Transpose(rangeFrom)  ' from 2D array to 1D array
s = Join(a, ";")
a = Split(s, ";")               ' sorry about my lazy variable names :]

For Each s In a
    v = Split(s, ",")           ' 3 values
    c = UBound(v) + 1           ' UBound(v) is 2
    rangeTo.Resize(, c) = v     ' resize to 3 columns
    Set rangeTo = rangeTo(2)    ' moves to the cell below
Next