Using VBA to separate and stack data from an Excel Cell

[geewhysee]

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
[TABLE="width: 500"]
<tbody>[TR]
[TD]Start Time[/TD]
[TD]Details[/TD]
[/TR]
[TR]
[TD]17/07/2016[/TD]
[TD]Jeffsmith@gmail.com,Jeff Smith,555-4196;BobJones@Gmail.com,Bob Jones,555-3827[/TD]
[/TR]
</tbody>[/TABLE]
needs to become
[TABLE="width: 500"]
<tbody>[TR]
[TD]Start Time[/TD]
[TD]Details[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]17/07/2016[/TD]
[TD]Jeffsmith@gmail.com[/TD]
[TD]Jeff Smith[/TD]
[TD]555-4196[/TD]
[/TR]
[TR]
[TD]17/07/2016[/TD]
[TD]BobJones@gmail.com[/TD]
[TD]Bob Jones[/TD]
[TD]555-3827[/TD]
[/TR]
</tbody>[/TABLE]

and so on for each cell no matter how many meail addresses etc there are in B2 B3 B4 and B5 So far I have tried using inserts with the following code

<code style="margin: 0px; padding: 0px; border: 0px; font-family: Consolas, Menlo, Monaco, "Lucida Console", "Liberation Mono", "DejaVu Sans Mono", "Bitstream Vera Sans Mono", "Courier New", monospace, sans-serif; white-space: inherit;">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 <>0Then
Rows("3:"&1+ RowNum1).EntireRow.Insert
EndIf

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

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

</code>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.

 

[wideboydixon]

I fully commented this code so hopefully you can learn from it:

Option Base 0
Public Sub SeparateAndStack()

Dim lastRow As Long
Dim thisRow As Long
Dim detailRows() As String
Dim rowDetails() As String
Dim rowCount As Long
Dim detailCount As Long

' Let's find the last row with data in column B
lastRow = Cells(Rows.Count, 2).End(xlUp).Row

' This is the row we're looking at
thisRow = 2

' Process all the rows we have
Do While thisRow <= lastRow
    ' Split the data in Column B at each ";" character to get the number of rows contained
    detailRows = Split(Cells(thisRow, 2).Value, ";")
    
    ' Now process each row of data
    For rowCount = 0 To UBound(detailRows)
        ' Do we need to insert a new row in to the sheet?
        If rowCount > 0 Then
            ' Yes ... insert the new row
            Rows(thisRow + rowCount).Insert xlShiftDown
            
            ' And copy the date in column A
            Cells(thisRow + rowCount, 1).Value = Cells(thisRow + rowCount - 1, 1).Value
        End If
        
        ' Details are delimited by commas
        rowDetails = Split(detailRows(rowCount), ",")
        
        ' Process each detail
        For detailCount = 0 To UBound(rowDetails)
            Cells(thisRow + rowCount, 2 + detailCount).Value = rowDetails(detailCount)
        Next detailCount
    Next rowCount
    
    ' Adjust the last row according to the number of rows we just added
    lastRow = lastRow + UBound(detailRows)
    
    ' Adjust the current row to the next one
    thisRow = thisRow + UBound(detailRows) + 1
Loop

End Sub

WBD

 

[MickG]

Another option for results starting "D1"

[COLOR="Navy"]Sub[/COLOR] MG28Jul49
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Sp [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    Sp = Split(Dn.Offset(, 1).Value, ";")
    [COLOR="Navy"]For[/COLOR] n = 0 To UBound(Sp)
        c = c + 1
        Cells(c, "D") = Dn.Value
            [COLOR="Navy"]If[/COLOR] c = 1 [COLOR="Navy"]Then[/COLOR]
                Cells(c, "E") = Dn.Offset(, 1).Value
            [COLOR="Navy"]Else[/COLOR]
                Cells(c, "E").Resize(, 3) = (Split(Application.Transpose(Sp(n)), ","))
            [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] n
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[geewhysee]

wide,

That is incredibly useful. Does the job and teaches at the same time. Cheers.