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

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.
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
469
dmt32
D
B
  • Solved
VBA to check if worksheet exists
Replies
8
Views
345
bdt
B
F
  • Solved
Issue with VBA code I created for work
Replies
7
Views
879
KAPOK
K
M
  • Question Question
VLOOKUP?
Replies
1
Views
222
MeaclH
M
C
  • Question Question
Ordinary Hours or Penalty Shift
Replies
0
Views
420
ChetanPuri
C

Forum statistics

Threads
1,224,823
Messages
6,181,178
Members
453,021
Latest member
Justyna P

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