VBA to transpose dataset and add a piece of data

wholly

New Member
Joined
Feb 18, 2013
Messages
16
Need to write vba code to sort of transpose from a horizontal data set to a vertical data set with an extra piece of data created.

If the table 1 has no data for mon -> sun just skip

Is there an easy way.. I just seem to be way our of my depth here!!

This data set has like 10,000 centres, so doing it by hand will take forever!!!

Thanks in advance



TABLE 1 - Original

ServiceApprovalNumberRatingsIssuedLast Service Approval Transfer DateAnnual Monday Start TimeAnnual Monday End TimeAnnual Tuesday Start TimeAnnual Tuesday End TimeAnnual Wednesday Start TimeAnnual Wednesday End TimeAnnual Thursday Start TimeAnnual Thursday End TimeAnnual Friday Start TimeAnnual Friday End Timelisting_id
SE-00009863Jul-16########6:3018:306:3018:306:3018:306:3018:306:3018:30155
SE-00009865Jun-14########7.4517.457.4517.457.4517.457.4517.457.4517.45255
New Sheet - TABLE 2
ServiceApprovalNumber listing_iddayopen_time close_timewhere day
SE-0000986315506:3018:300 = Monday
SE-0000986415516:3018:301 = Tuesday
SE-0000986515526:3018:302 = Wednesday
SE-0000986615536:3018:30
SE-0000986715546:3018:30skip if no hours data
SE-0000986525507.4517.45
SE-0000986625517.4517.45
SE-0000986725527.4517.45
SE-0000986825537.4517.45
SE-0000986925547.4517.45

<colgroup><col><col span="2"><col><col span="10"></colgroup><tbody>
</tbody>
 

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.
wholly,

You might consider the following...

Code:
Sub TransposeArray_1069847()
Dim arr1 As Variant, arr2() As Variant
Dim rws As Long, r As Long, c As Long, i As Long, san As Long

rws = WorksheetFunction.CountA(Sheets(1).Range(Cells(2, 4), Cells(Sheets(1).UsedRange.Rows.Count, 13))) / 2
arr1 = Sheets(1).UsedRange
ReDim arr2(1 To rws + 1, 1 To 5)

arr2(1, 1) = "ServiceApprovalNumber"
arr2(1, 2) = "listing_id"
arr2(1, 3) = "day"
arr2(1, 4) = "open_time"
arr2(1, 5) = "close_time"
i = 2

For r = 2 To UBound(arr1)
    For c = 4 To 12 Step 2
        Select Case c
            Case 4
                If arr1(r, c) <> "" Then
                    san = Split(arr1(r, 1), "-")(1)
                    arr2(i, 1) = arr1(r, 1)
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "0"
                    arr2(i, 4) = Format(arr1(r, 4), "h:mm")
                    arr2(i, 5) = Format(arr1(r, 5), "h:mm")
                    i = i + 1
                End If
            Case 6
                If arr1(r, c) <> "" Then
                    If san > 0 Then
                        san = san + 1
                        arr2(i, 1) = Split(arr1(r, 1), "-")(0) & "-" & Format(san, "00000000")
                    Else
                        san = Split(arr1(r, 1), "-")(1)
                        arr2(i, 1) = arr1(r, 1)
                    End If
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "1"
                    arr2(i, 4) = Format(arr1(r, 4), "h:mm")
                    arr2(i, 5) = Format(arr1(r, 5), "h:mm")
                    i = i + 1
                End If
            Case 8
                If arr1(r, c) <> "" Then
                    If san > 0 Then
                        san = san + 1
                        arr2(i, 1) = Split(arr1(r, 1), "-")(0) & "-" & Format(san, "00000000")
                    Else
                        san = Split(arr1(r, 1), "-")(1)
                        arr2(i, 1) = arr1(r, 1)
                    End If
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "2"
                    arr2(i, 4) = Format(arr1(r, 4), "h:mm")
                    arr2(i, 5) = Format(arr1(r, 5), "h:mm")
                    i = i + 1
                End If
            Case 10
                If arr1(r, c) <> "" Then
                    If san > 0 Then
                        san = san + 1
                        arr2(i, 1) = Split(arr1(r, 1), "-")(0) & "-" & Format(san, "00000000")
                    Else
                        san = Split(arr1(r, 1), "-")(1)
                        arr2(i, 1) = arr1(r, 1)
                    End If
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "3"
                    arr2(i, 4) = Format(arr1(r, 4), "h:mm")
                    arr2(i, 5) = Format(arr1(r, 5), "h:mm")
                    i = i + 1
                End If
            Case 12
                If arr1(r, c) <> "" Then
                    If san > 0 Then
                        san = san + 1
                        arr2(i, 1) = Split(arr1(r, 1), "-")(0) & "-" & Format(san, "00000000")
                    Else
                        san = Split(arr1(r, 1), "-")(1)
                        arr2(i, 1) = arr1(r, 1)
                    End If
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "4"
                    arr2(i, 4) = Format(arr1(r, 4), "h:mm")
                    arr2(i, 5) = Format(arr1(r, 5), "h:mm")
                    i = i + 1
                End If
        End Select
    Next c
Next r
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1").Resize(rws + 1, 5).Value = arr2
ActiveSheet.Columns.AutoFit
End Sub

It's assumed that every start time has a corresponding end time. It's also assumed that start and end times in the original table are in actual time formats (which doesn't appear to be the case in the sample data.)

Cheers,

tonyyy
 
Last edited:
Upvote 0
Sorry, need to make a slight change...

Code:
Sub TransposeArray_1069847()
Dim arr1 As Variant, arr2() As Variant
Dim rws As Long, r As Long, c As Long, i As Long, san As Long

rws = WorksheetFunction.CountA(Sheets(1).Range(Cells(2, 4), Cells(Sheets(1).UsedRange.Rows.Count, 13))) / 2
arr1 = Sheets(1).UsedRange
ReDim arr2(1 To rws + 1, 1 To 5)

arr2(1, 1) = "ServiceApprovalNumber"
arr2(1, 2) = "listing_id"
arr2(1, 3) = "day"
arr2(1, 4) = "open_time"
arr2(1, 5) = "close_time"
i = 2

For r = 2 To UBound(arr1)
    For c = 4 To 12 Step 2
        Select Case c
            Case 4
                If arr1(r, c) <> "" Then
                    san = Split(arr1(r, 1), "-")(1)
                    arr2(i, 1) = arr1(r, 1)
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "0"
                    arr2(i, 4) = Format(arr1(r, c), "h:mm")
                    arr2(i, 5) = Format(arr1(r, c + 1), "h:mm")
                    i = i + 1
                End If
            Case 6
                If arr1(r, c) <> "" Then
                    If san > 0 Then
                        san = san + 1
                        arr2(i, 1) = Split(arr1(r, 1), "-")(0) & "-" & Format(san, "00000000")
                    Else
                        san = Split(arr1(r, 1), "-")(1)
                        arr2(i, 1) = arr1(r, 1)
                    End If
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "1"
                    arr2(i, 4) = Format(arr1(r, c), "h:mm")
                    arr2(i, 5) = Format(arr1(r, c + 1), "h:mm")
                    i = i + 1
                End If
            Case 8
                If arr1(r, c) <> "" Then
                    If san > 0 Then
                        san = san + 1
                        arr2(i, 1) = Split(arr1(r, 1), "-")(0) & "-" & Format(san, "00000000")
                    Else
                        san = Split(arr1(r, 1), "-")(1)
                        arr2(i, 1) = arr1(r, 1)
                    End If
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "2"
                    arr2(i, 4) = Format(arr1(r, c), "h:mm")
                    arr2(i, 5) = Format(arr1(r, c + 1), "h:mm")
                    i = i + 1
                End If
            Case 10
                If arr1(r, c) <> "" Then
                    If san > 0 Then
                        san = san + 1
                        arr2(i, 1) = Split(arr1(r, 1), "-")(0) & "-" & Format(san, "00000000")
                    Else
                        san = Split(arr1(r, 1), "-")(1)
                        arr2(i, 1) = arr1(r, 1)
                    End If
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "3"
                    arr2(i, 4) = Format(arr1(r, c), "h:mm")
                    arr2(i, 5) = Format(arr1(r, c + 1), "h:mm")
                    i = i + 1
                End If
            Case 12
                If arr1(r, c) <> "" Then
                    If san > 0 Then
                        san = san + 1
                        arr2(i, 1) = Split(arr1(r, 1), "-")(0) & "-" & Format(san, "00000000")
                    Else
                        san = Split(arr1(r, 1), "-")(1)
                        arr2(i, 1) = arr1(r, 1)
                    End If
                    arr2(i, 2) = arr1(r, 14)
                    arr2(i, 3) = "4"
                    arr2(i, 4) = Format(arr1(r, c), "h:mm")
                    arr2(i, 5) = Format(arr1(r, c + 1), "h:mm")
                    i = i + 1
                End If
        End Select
    Next c
Next r
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1").Resize(rws + 1, 5).Value = arr2
ActiveSheet.Columns.AutoFit
End Sub
 
Upvote 0
Thank you

I will give your script a try....

BTW. I should have stated that the time fields is structured as time and not just numbers

Once again, a huge thanks!!!

Wayne
 
Upvote 0
Hi..

Just dropped the script in from above, and it didn't work, just gave an error message

Am I doing something wrong???
 
Upvote 0
if needed I can email my spreadsheet..

All data contained is publicly available and not sensitive.

Other than being Commercial in Confidence by nature.

wayne
 
Upvote 0
What's the error number/description you're getting? And which line of code is highlighted when the error occurs?
 
Upvote 0
What's the error number/description you're getting? And which line of code is highlighted when the error occurs?


Error 1004


rws = WorksheetFunction.CountA(Sheets(1).Range(Cells(2, 4), Cells(Sheets(1).UsedRange.Rows.Count, 13))) / 2


it shows that rws = 0

thanks tonyyy
 
Upvote 0
Please replace the offending line with...

Code:
rws = Application.WorksheetFunction.CountA(Sheets("Sheet1").Range(Sheets("Sheet1").Cells(2, 4), Sheets("Sheet1").Cells(Sheets("Sheet1").UsedRange.Rows.Count, 13))) / 2


And please replace "Sheet1" with "yoursheetname"... not literally, but with the name of the sheet that contains Table 1.
 
Upvote 0
Hi tonyyy,

thanks for the update...

I now have the following problem in the script.

arr2(i, 1) = arr1(r, 1) [arr1(r, 1) shows the SE-number]

arr2(i, 1) = <Subscript out of range>

BTW.. I am using your 1st script as all the numbers within the code are time formatted.

kind regards

wayne
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,186
Members
448,554
Latest member
Gleisner2

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