VBA: Add Columns and Separate Cell Contents Into Columns

mtnblue

New Member
Joined
Apr 22, 2021
Messages
5
Office Version
  1. 365
Platform
  1. Windows
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:
ABCD
NameDate TimeAmountDetails
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
ABCDEFGHI
NameDate TimeDateTimeAmountQuantityPriceAgeProduct
Mickey
3/11/21 3:34​
3/11/21​
3:34:43 AM​
280​
7​
40​
AdultLift 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 UnderLift 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)

AgeProduct
AdultLift Ticket
Youth (6-12)Rental
5 and Under
Student/Military/Senior

Thanks!
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
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.
VBA Code:
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
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
Microsoft Visual Basic
Run-time error '1004':
Application-defined or object-defined error

Thanks again!
 
Upvote 0
I managed to replicate the error (sort of), and recoded the date/time calculation part.

Try this:
VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,223,903
Messages
6,175,287
Members
452,631
Latest member
a_potato

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top