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

Posted 2023-04-12

【中文标题】VBA 从多列复制和粘贴转置数据

【英文标题】：VBA Copy and Paste Transpose data from Multiple columns

【发布时间】：2017-08-14 23:40:36

【问题描述】：

我设置了多个时间表工作簿，其中包含员工姓名和不同时间类型的多个列（例如，基本时间、假期工资、病假工资）。见图片。

我需要代码才能将每个员工的小时类型（标题）和值复制到 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

Example Timesheet File

Example Upload Template

【问题讨论】：

这看起来像是一个常规的“反透视”操作：这里有一个 VBA 解决方案 - ***.com/questions/36365839/…

@TimWilliams 谢谢 - 我无法将其放入上述代码中。我收到运行时错误 9 下标超出范围。

【参考方案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

【讨论】：

非常感谢 - 我收到另一个错误 - 编译错误：预期数组在 .Resize(Ubound(p,1),Ubound(p,2)).value = p

我在上面提到的<edited> 部分有一个错误 - 尝试修复...

感谢您的编辑 - 仍需要尝试一些调试，因为在 Ubound 部分收到预期的数组错误。

我看不到您的输入数据，所以除非您可以共享文件，否则我无能为力。

我已经包含了一个指向示例时间表（源数据）文件和带有当前代码的模板的谷歌驱动器链接。