[英]VBA Copy and Paste Transpose data from Multiple columns
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. 我需要代码,以便能够将每个员工的小时类型(标题)和值复制到4列中。
eg. 例如。
Employee 1 Base Hours 37.50
员工1基本时间37.50
Employee 1 Sick Hours 15.00
员工1病假时间15.00
Employee 1 Group Leader 20.00
员工1组长20.00
Employee 2 Base Hours 50.00
员工2基本时间50.00
Employee 2 Holiday Pay 60.00
员工2假期工资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
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.