VBA: Add Columns and Separate Cell Contents Into Columns

[mtnblue]

Hello Excel Gurus and thanks for any help you're able to provide!
I have a file with 27 columns (A:AA) and 202 rows (plus 1 header row).
I have three columns that I need help with.
I suspect a VBA Loop of some sort is needed but I don’t know how to write it to combine all the elements.

One: Column B, Date Time, appears as: 3/18/2021 8:25:11 PM
I would like to add two new columns, C and D, and,

Capture the Date in column C (I’m using =INT(B2) and then formatting as Short Date)​

Capture the Time in column D (I’m using =B2-INT(B2) and then formatting as Time 13:30)​

I've also done this using Record Macro and that would be fine if this was the only step needed.​

Two: Column D, Details
This column contains multiple elements that need to be separated into columns and rows
Sometimes this cell contains only one line of Quantity/Price/Age/Product, and other times multiple lines
The first line is always blank, the last line is always Subtotal, the other characters and spacing are consistent
Sample data from one cell (5 lines):

​

7 x $40.00 : Adult Lift Ticket​

5 x $20.00 : Youth (6-12) Lift Ticket​

4 x $0.00 : 5 and Under Lift Ticket​

Subtotal : $380.00​

I have used this formula to break this apart on the same row:

= TRIM( MID(SUBSTITUTE( $F2, CHAR(10), REPT( " ",LEN($F2) ) ), (AD$1-1)*LEN($F2)+1, LEN($F2)) )​

F2 is Details
AD1 is the occurrence number that I manually added (above data would have 5 columns)
Result in a single cell: 7 x $40.00 : Adult Lift Ticket
I then deleted the columns with the first blank line and the subtotal line.
And, of course, I still didn’t get to my goal of having each element in a separate column.
Ultimately, this approach didn’t help me get to the point of actually analyzing the data set and was a very manual process.

Three: Column C, Amount
This is the Subtotal from Column D and appears as 380
As Step Two is completed, this needs to reflect the subtotal of the row.

Go from this:

A	B	C	D
Name	Date Time	Amount	Details
Mickey	3/11/21 3:34​	380​	7 x $40.00 : Adult Lift Ticket 5 x $20.00 : Youth (6-12) Lift Ticket 4 x $0.00 : 5 and Under Lift Ticket Subtotal : $380.00

To this:

• Amount is F*G
• No need to keep the Details column
• keep the other columns to the right, copied by row as necessary

A	B	C	D	E	F	G	H	I
Name	Date Time	Date	Time	Amount	Quantity	Price	Age	Product
Mickey	3/11/21 3:34​	3/11/21​	3:34:43 AM​	280​	7​	40​	Adult	Lift Ticket
Mickey	3/11/21 3:34​	3/11/21​	3:34:43 AM​	100​	5​	20​	Youth (6-12)	Lift Ticket
Mickey	3/11/21 3:34​	3/11/21​	3:34:43 AM​	0​	4​	0​	5 and Under	Lift Ticket

Important notes:
Quantity – no instances in the data of this being more than a single digit
Price – instances in the data include: $00.00 and $0.00 and I'm okay with this becoming 0
Age – there are four categories (see table below)
Product – there are two categories (see table below)

Age	Product
Adult	Lift Ticket
Youth (6-12)	Rental
5 and Under
Student/Military/Senior

Thanks!

 

[aRandomHelper]

Welcome to the forum!

Very nice and detailed post of your question.

Please try running this on a copy of your "from" worksheet. A new worksheet will be added. Without enough sample data, I am unsure how the date formats and/or other Age/Product types would go, hopefully it doesn't go wonky.

Sub ME1168960_SplitData()
    Dim i As Long, j As Long, c As Long, c2 As Long, v, v2
    Dim a, b, s, headers, headers2
   
    headers = Array("Name", "Date Time", "Date", "Time", "Amount", "Quantity", "Price", "Age", "Product")
   
    With ActiveSheet
        headers2 = .Range("E1", .Cells(1, .Columns.Count).End(xlToLeft)).Value
        a = .Range("A2:AA" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value 'ignore header row
       
        For i = 1 To UBound(a, 1)
            c2 = c2 + UBound(Split(a(i, 4), vbLf))
        Next
       
        ReDim b(1 To c2, 1 To UBound(a, 2) + 5)
        c = 1
       
        For i = 1 To UBound(a, 1)
            If a(i, 4) <> "" Then
                v = Split(a(i, 4), vbLf)
               
                For Each s In v
                    If s <> "" And InStr(s, "Subtotal") = 0 Then
                        b(c, 1) = a(i, 1) 'name
                        b(c, 2) = a(i, 2) 'date time
                        b(c, 3) = CLng(CDate(a(i, 2))) 'date
                        b(c, 4) = a(i, 2) - CLng(CDate(a(i, 2))) 'time
                       
                        v2 = Split(s, " x ")
                        If v2(0) <> "" Then
                            b(c, 6) = v2(0) 'quantity
                           
                            v2 = Split(v2(1), " : ")
                            If v2(0) <> "" Then
                                b(c, 7) = v2(0) 'price
                            End If
                            If InStr(v2(1), "Lift Ticket") > 0 Then
                                b(c, 8) = Trim(Replace(v2(1), "Lift Ticket", "")) 'age
                                b(c, 9) = "Lift Ticket" 'product
                            Else
                                b(c, 8) = Trim(Replace(v2(1), "Rental", "")) 'age
                                b(c, 9) = "Rental" 'product
                            End If
                           
                            b(c, 5) = b(c, 6) * b(c, 7) 'amount
                           
                            For j = 5 To UBound(a, 2)
                                b(c, 5 + j) = a(i, j) 'remaining columns
                            Next
                           
                            c = c + 1
                        End If
                    End If
                Next
            End If
        Next
    End With
   
    With Sheets.Add
        .Range("A1:I1").Value = headers
        .Range("J1").Resize(1, UBound(headers2, 2)).Value = headers2
        .Rows(1).Font.Bold = True
       
        .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
        .Columns(2).NumberFormat = "d/mm/yy h:mm"
        .Columns(3).NumberFormat = "d/mm/yy"
        .Columns(4).NumberFormat = "h:mm:ss AM/PM"
        .UsedRange.EntireColumn.AutoFit
    End With
   
End Sub

 

[mtnblue]

Hi aRandomHelper - thank you for this code!

I ran it several times and it does work just as hoped except for this pesky little error which seems to be triggered by data with Date Time that is AM. I changed the AM to PM on the record where the code stopped working and reran the macro and it worked for that row and several more until the next Date Time AM record.

The debugger highlights the bold bit in this section near the end:

End With

With Sheets.Add
.Range("A1:I1").Value = headers
.Range("J1").Resize(1, UBound(headers2, 2)).Value = headers2
.Rows(1).Font.Bold = True

.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
.Columns(2).NumberFormat = "d/mm/yy h:mm"
.Columns(3).NumberFormat = "d/mm/yy"
.Columns(4).NumberFormat = "h:mm:ss AM/PM"
.UsedRange.EntireColumn.AutoFit
End With

End Sub


I'm not sure what part of the code to tweak to fix this. Any ideas?

Thanks again for the help and the quick response.

 

[aRandomHelper]

What was the error message shown? I am not with my computer right now, so I'll check back most likely tomorrow and test it.

 

[mtnblue]

Microsoft Visual Basic
Run-time error '1004':
Application-defined or object-defined error

Thanks again!

 

[aRandomHelper]

I managed to replicate the error (sort of), and recoded the date/time calculation part.

Try this:

Sub ME1168960_SplitData()
    Dim i As Long, j As Long, c As Long, c2 As Long, v, v2, d As Double
    Dim a, b, s, headers, headers2
   
    headers = Array("Name", "Date Time", "Date", "Time", "Amount", "Quantity", "Price", "Age", "Product")
   
    With ActiveSheet
        headers2 = .Range("E1", .Cells(1, .Columns.Count).End(xlToLeft)).Value
        a = .Range("A2:AA" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value 'ignore header row
       
        For i = 1 To UBound(a, 1)
            c2 = c2 + UBound(Split(a(i, 4), vbLf))
        Next
       
        ReDim b(1 To c2, 1 To UBound(a, 2) + 5)
        c = 1
       
        For i = 1 To UBound(a, 1)
            If a(i, 4) <> "" Then
                v = Split(a(i, 4), vbLf)
               
                For Each s In v
                    If s <> "" And InStr(s, "Subtotal") = 0 Then
                        b(c, 1) = a(i, 1) 'name
                        d = CDbl(a(i, 2))
                        b(c, 2) = CDate(d) 'date time
                        b(c, 3) = CLng(Application.RoundDown(d, 0)) 'date
                        b(c, 4) = d - b(c, 3) 'time
                       
                        v2 = Split(s, " x ")
                        If v2(0) <> "" Then
                            b(c, 6) = v2(0) 'quantity
                           
                            v2 = Split(v2(1), " : ")
                            If v2(0) <> "" Then
                                b(c, 7) = v2(0) 'price
                            End If
                            If InStr(v2(1), "Lift Ticket") > 0 Then
                                b(c, 8) = Trim(Replace(v2(1), "Lift Ticket", "")) 'age
                                b(c, 9) = "Lift Ticket" 'product
                            Else
                                b(c, 8) = Trim(Replace(v2(1), "Rental", "")) 'age
                                b(c, 9) = "Rental" 'product
                            End If
                           
                            b(c, 5) = b(c, 6) * b(c, 7) 'amount
                           
                            For j = 5 To UBound(a, 2)
                                b(c, 5 + j) = a(i, j) 'remaining columns
                            Next
                           
                            c = c + 1
                        End If
                    End If
                Next
            End If
        Next
    End With
   
    With Sheets.Add
        .Range("A1:I1").Value = headers
        .Range("J1").Resize(1, UBound(headers2, 2)).Value = headers2
        .Rows(1).Font.Bold = True
       
        .Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
        .Columns(2).NumberFormat = "d/mm/yy h:mm"
        .Columns(3).NumberFormat = "d/mm/yy"
        .Columns(4).NumberFormat = "h:mm:ss AM/PM"
        .UsedRange.EntireColumn.AutoFit
    End With
   
End Sub

 

[mtnblue]

Yes, that seems to work - thank you!