excel - VBA Copy and Paste Transpose data from Multiple columns -
i have multiple timesheet workbooks set has employee name , multiple columns different hour types (eg. base hours, holiday pay, sick pay). see image .
i need code able copy each employee type of hours (heading) , value 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 code copies data template stuck on how copy above.
sub consolidate() application.enablecancelkey = xldisabled dim folderpath string dim filename string dim wb workbook dim fname string dim fpath string dim newbook workbook folderpath = "c:\users\preena.j\documents\payroll\timesheet - myob" 'contains folder path if right(folderpath, 1) <> "\" folderpath = folderpath + "\" filename = dir(folderpath & "*.xlsx") 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) <> "" msgbox "file " & fpath & "\" & fname & " exists" else newbook.saveas filename:=fpath & "\" & fname, fileformat:=xlcsv end if newbook.close savechanges:=true end sub
using function @ link posted, (untested):
option explicit sub consolidate() application.enablecancelkey = xldisabled dim folderpath string dim filename string dim wb workbook dim fname string dim fpath string dim newbook workbook folderpath = "c:\users\preena.j\documents\payroll\timesheet - myob" 'contains folder path if right(folderpath, 1) <> "\" folderpath = folderpath + "\" filename = dir(folderpath & "*.xlsx") dim rngdata, p, shtdest worksheet set shtdest = workbooks("myobtimesheetimport").worksheets("myobtimesheetimport") while filename <> "" application.screenupdating = false set wb = workbooks.open(folderpath & filename) '<edited> range containing data wb.sheets("timesheet") set rngdata = .range("a9:n" & _ .range("a" & .rows.count).end(xlup).row) end '</edited> p = unpivotdata(rngdata, 2, true, false) '<< unpivot 'put unpivoted data sheet shtdest.cells(rows.count, "a").end(xlup).offset(1, 0) .resize(ubound(p, 1), ubound(p, 2)).value = p end 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) <> "" msgbox "file " & fpath & "\" & fname & " exists" else newbook.saveas filename:=fpath & "\" & fname, fileformat:=xlcsv end if newbook.close savechanges:=true end sub
Comments
Post a Comment