VBA复制和粘贴从多列转移数据

Question

我有多个时间表工作簿设置具有员工名称和多个不同小时类型的列（如基地时间，假期支付，病假工资）。见图片。

我需要代码才能够为每个员工复制小时类型（标题）和值为4列。

例如。

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

我有一些代码将数据复制到模板当前，但坚持如何复制它如上。

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

Answer 1

使用在我发布的链接的功能，像这样（未经）：

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