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

我有多个时间表工作簿设置具有员工名称和多个不同小时types（如基准时间，假日薪酬，病假工资）列。 看图片。

我需要代码才能将每个员工的小时types（标题）和值复制到4列。

例如。

员工1基准时间37.50

员工1病假15.00

员工1组长20.00

员工2基准时间50.00

员工2假期支付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 

示例时间表文件

示例上传模板

Answer 1

使用我发布的链接的function，像这样（未经testing）：

 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