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>
 

tonyyy

Well-known Member
Joined
Jun 24, 2015
Messages
1,647
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:

tonyyy

Well-known Member
Joined
Jun 24, 2015
Messages
1,647
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
 

wholly

New Member
Joined
Feb 18, 2013
Messages
16
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
 

wholly

New Member
Joined
Feb 18, 2013
Messages
16
Hi..

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

Am I doing something wrong???
 

wholly

New Member
Joined
Feb 18, 2013
Messages
16
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
 

tonyyy

Well-known Member
Joined
Jun 24, 2015
Messages
1,647
What's the error number/description you're getting? And which line of code is highlighted when the error occurs?
 

wholly

New Member
Joined
Feb 18, 2013
Messages
16
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
 

tonyyy

Well-known Member
Joined
Jun 24, 2015
Messages
1,647
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.
 

wholly

New Member
Joined
Feb 18, 2013
Messages
16
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
 

Forum statistics

Threads
1,082,500
Messages
5,365,935
Members
400,863
Latest member
kimtid

Some videos you may like

This Week's Hot Topics

Top