VBA Copy and Paste Transpose data from Multiple columns

Question

I have multiple Timesheet workbooks set up which has Employee Name and multiple columns for different hour types (eg. Base Hours, Holiday Pay, Sick Pay). See image .

I need code to be able to copy for each employee the type of hours (heading) and the value into 4 columns.

eg.

Employee 1 Base Hours 37.50

Employee 1 Sick Hours 15.00

Employee 1 Group Leader 20.00

Employee 2 Base Hours 50.00

Employee 2 Holiday Pay 60.00

I have some code which copies the data to a template currently but stuck on how to copy it as above.

Sub Consolidate()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim FName As String
Dim FPath As String
Dim NewBook As Workbook


folderPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB" 
'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)


wb.Sheets("Timesheet").Range("A9:N" & Range("A" & 
Rows.Count).End(xlUp).Row).Copy

Workbooks("MYOBTimeSheetImport").Worksheets("MYOBTimeSheetImport").Range("A" 
& Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues


    Workbooks(Filename).Close True
    Filename = Dir
Loop


Application.ScreenUpdating = True

FPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
FName = "MYOBTimeSheetImport_" & Format(Now(), "YYYYMMDD")

Set NewBook = Workbooks.Add

ThisWorkbook.Sheets("MYOBTimeSheetImport").Copy Before:=NewBook.Sheets(1)

If Dir(FPath & "\" & FName) <> "" Then
     MsgBox "File " & FPath & "\" & FName & " already exists"
Else
    NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlCSV
End If
    NewBook.Close savechanges:=True
 End Sub

Example Timesheet File

Example Upload Template

This looks like a regular "unpivot" operation: there is a VBA solution here - https://stackoverflow.com/questions/36365839/excel-macrovba-to-transpose-multiple-columns-to-multiple-rows/36366394#36366394 — Tim Williams, Aug 15 '17 at 00:01
@TimWilliams Thanks - I am having trouble fitting this into the above code. I am getting a runtime error 9 Subscript out of range. — Preena, Aug 15 '17 at 00:23

Tim Williams · Answer 1 · 2017-08-15T04:50:22.730

Using the function at the link I posted, something like this (untested):

Option Explicit

Sub Consolidate()

    Application.EnableCancelKey = xlDisabled
    Dim folderPath As String
    Dim Filename As String
    Dim wb As Workbook
    Dim FName As String
    Dim FPath As String
    Dim NewBook As Workbook

    folderPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
    'contains folder path
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
    Filename = Dir(folderPath & "*.xlsx")


    Dim rngData, p, shtDest As Worksheet
    Set shtDest = Workbooks("MYOBTimeSheetImport").Worksheets("MYOBTimeSheetImport")

    Do While Filename <> ""

        Application.ScreenUpdating = False
        Set wb = Workbooks.Open(folderPath & Filename)

        '<edited> range containing your data
        With wb.Sheets("Timesheet")
            Set rngData = .Range("A9:N" & _
                      .Range("A" & .Rows.Count).End(xlUp).Row)
        End with
        '</edited>

        p = UnPivotData(rngData, 2, True, False) '<< unpivot

        'put unpivoted data to sheet
        With shtDest.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
            .Resize(UBound(p, 1), UBound(p, 2)).Value = p
        End With

        Workbooks(Filename).Close True
        Filename = Dir
    Loop

    Application.ScreenUpdating = True

    FPath = "C:\Users\preena.j\Documents\Payroll\TimeSheet - MYOB"
    FName = "MYOBTimeSheetImport_" & Format(Now(), "YYYYMMDD")

    Set NewBook = Workbooks.Add

    ThisWorkbook.Sheets("MYOBTimeSheetImport").Copy Before:=NewBook.Sheets(1)

    If Dir(FPath & "\" & FName) <> "" Then
         MsgBox "File " & FPath & "\" & FName & " already exists"
    Else
        NewBook.SaveAs Filename:=FPath & "\" & FName, FileFormat:=xlCSV
    End If

    NewBook.Close savechanges:=True

End Sub

Thank you so much - I am getting another error - Compile Error:Expected array at .Resize(Ubound(p,1),Ubound(p,2)).value = p — Preena, Aug 15 '17 at 00:55
I had an error in the part noted `` above - try with that fix... — Tim Williams, Aug 15 '17 at 04:50
Thank you for the edit - will need to still try some debugging as receiving the Expected array error at the Ubound section. — Preena, Aug 16 '17 at 23:38
I can't see your input data, so unless you can share a file i can't help. — Tim Williams, Aug 16 '17 at 23:42
I have included a google drive link to an example timesheet (source data) file and the template with current code. — Preena, Aug 18 '17 at 00:20

VBA Copy and Paste Transpose data from Multiple columns

1 Answers1