VBA to transpose dataset and add a piece of data

W

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

[TABLE="width: 1000"]
<colgroup><col><col span="2"><col><col span="10"></colgroup><tbody>[TR]
[TD]ServiceApprovalNumber[/TD]
[TD]RatingsIssued[/TD]
[TD]Last Service Approval Transfer Date[/TD]
[TD]Annual Monday Start Time[/TD]
[TD]Annual Monday End Time[/TD]
[TD]Annual Tuesday Start Time[/TD]
[TD]Annual Tuesday End Time[/TD]
[TD]Annual Wednesday Start Time[/TD]
[TD]Annual Wednesday End Time[/TD]
[TD]Annual Thursday Start Time[/TD]
[TD]Annual Thursday End Time[/TD]
[TD]Annual Friday Start Time[/TD]
[TD]Annual Friday End Time[/TD]
[TD]listing_id[/TD]
[/TR]
[TR]
[TD]SE-00009863[/TD]
[TD="align: right"]Jul-16[/TD]
[TD="align: center"]########[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD="align: right"]155[/TD]
[/TR]
[TR]
[TD]SE-00009865[/TD]
[TD="align: right"]Jun-14[/TD]
[TD="align: center"]########[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD="align: right"]255[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]New Sheet - TABLE 2[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]ServiceApprovalNumber [/TD]
[TD]listing_id[/TD]
[TD]day[/TD]
[TD]open_time [/TD]
[TD="colspan: 2"]close_time[/TD]
[TD][/TD]
[TD="colspan: 2"]where day[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009863[/TD]
[TD="align: right"]155[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD][/TD]
[TD][/TD]
[TD="colspan: 2"]0 = Monday[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009864[/TD]
[TD="align: right"]155[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD][/TD]
[TD][/TD]
[TD="colspan: 2"]1 = Tuesday[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009865[/TD]
[TD="align: right"]155[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD][/TD]
[TD][/TD]
[TD="colspan: 2"]2 = Wednesday[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009866[/TD]
[TD="align: right"]155[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009867[/TD]
[TD="align: right"]155[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]6:30[/TD]
[TD="align: right"]18:30[/TD]
[TD][/TD]
[TD][/TD]
[TD="colspan: 3"]skip if no hours data[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009865[/TD]
[TD="align: right"]255[/TD]
[TD="align: right"]0[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009866[/TD]
[TD="align: right"]255[/TD]
[TD="align: right"]1[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009867[/TD]
[TD="align: right"]255[/TD]
[TD="align: right"]2[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009868[/TD]
[TD="align: right"]255[/TD]
[TD="align: right"]3[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]SE-00009869[/TD]
[TD="align: right"]255[/TD]
[TD="align: right"]4[/TD]
[TD="align: right"]7.45[/TD]
[TD="align: right"]17.45[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Sort by date Sort by votes
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
tonyyy said:
What's the error number/description you're getting? And which line of code is highlighted when the error occurs?
Click to expand...


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
You must log in or register to reply here.

Similar threads

A
  • Question Question
VBA help - Locking & unlocking on certain times of day
2
Replies
17
Views
347
dmt32
D
B
  • Solved
VBA to check if worksheet exists
Replies
8
Views
314
bdt
B
F
  • Solved
Issue with VBA code I created for work
Replies
7
Views
872
KAPOK
K
M
  • Question Question
VLOOKUP?
Replies
1
Views
212
MeaclH
M
C
  • Question Question
Ordinary Hours or Penalty Shift
Replies
0
Views
414
ChetanPuri
C

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

Share this page

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