有没有一种快速的方法可以使用 VBA 或 R 重新格式化和编译 Excel 中的奇数数据？

Question

我在一个 Excel 工作簿中有超过 200 个 sheet ，每个都以非常奇怪的方式格式化，我需要弄清楚如何将我需要的所有数据编译成一个高手sheet。我只需要来自某些单元格和范围的值（如下面的代码所示）。我希望最终编译的 sheet 是长格式的（见附图）。

附上一张图片，它是每个 sheet 格式的示例 - 它包含所有单元格，但不包含任何实际数据。实际上，有很多数据——一些 sheet 有 >1000 行。

我尝试使用 R 中的一个函数将所有 sheet 作为单独的数据帧读入，以便我可以合并它们，但我无法让它工作。然后我尝试使用 VBA，但我不熟悉语法。这是我想出的：

Sub Copy_Example()

  Dim J As Integer
    Dim s As Worksheet

    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add ' add a sheet in first place
    Sheets(1).Name = "Combined"

Worksheets("Sheet2").Range("D9").Copy Destination:=Worksheets("Combined").Range("A2")
Worksheets("Sheet2").Range("E2").Copy Destination:=Worksheets("Combined").Range("B2")
Worksheets("Sheet2").Range("E3").Copy Destination:=Worksheets("Combined").Range("C2")
Worksheets("Sheet2").Range("E4").Copy Destination:=Worksheets("Combined").Range("D2")
Worksheets("Sheet2").Range("E5").Copy Destination:=Worksheets("Combined").Range("E2")
Worksheets("Sheet2").Range("C22:C2000").Copy Destination:=Worksheets("Combined").Range("F1")
Worksheets("Sheet2").Range("E22:E2000").Copy Destination:=Worksheets("Combined").Range("G1")
Worksheets("Sheet2").Range("F22:F2000").Copy Destination:=Worksheets("Combined").Range("H1")
Worksheets("Sheet2").Range("G22:G2000").Copy Destination:=Worksheets("Combined").Range("I1")
Worksheets("Sheet2").Range("H22:H2000").Copy Destination:=Worksheets("Combined").Range("J1")
Worksheets("Sheet2").Range("I22:I2000").Copy Destination:=Worksheets("Combined").Range("K1")

End Sub

此 VBA 会将正确的列和范围复制并粘贴到新创建的作品中 sheet 仅适用于 Sheet 2. 我尝试集成其他代码片段，以便此将运行遍历工作簿中的所有 sheet 并将数据粘贴到之前添加的最后一行下方，但我无法让它工作。我也希望能够添加一个列，其中包含从中复制数据的 sheet 的名称。

如果有人可以使用 R 或 VBA 帮助我解决这个问题，我将不胜感激。

This is an example of the format of each sheet

This is an example of what I'd like the master compiled sheet to look like

Answer 1

试试下面的代码

Sub CopyToCombined()

    Dim oComWS As Worksheet, oWS As Worksheet
    Dim iLR As Long: iLR = 1

    ' Add New sheet as "Combined"
    Set oComWS = ThisWorkbook.Worksheets.Add
    oComWS.Name = "Combined"

    ' Loop through all sheets in the workbook and copy details in Combined sheet
    For Each oWS In ThisWorkbook.Worksheets
        If oWS.Name <> "Combined" Then
            With oWS
                oComWS.Range("A" & iLR).Value = .Range("A3").Value
                oComWS.Range("B" & iLR).Value = .Range("B5").Value
                oComWS.Range("C" & iLR).Value = .Range("C26").Value
            End With
            iLR = iLR + 1
        End If
    Next

End Sub

以上代码将遍历您工作簿中的所有工作表并复制相关数据（显然您必须更改要复制的内容）

编辑 1： 根据要求，以下代码应根据您的要求更新 Combined

Sub CopyToCombined()

    Dim oComWS As Worksheet, oWS As Worksheet
    Dim iLR As Long: iLR = 1
    Dim iC As Long
    Dim aCleanArray As Variant, aMyRange As Variant, aColumn As Variant

    ' Add New sheet as "Combined"
    Set oComWS = ThisWorkbook.Worksheets.Add
    oComWS.Name = "Combined"

    ' Set arrays
    aMyRange = Array("C20:C50", "D20:D50")  ' <-- Set all your ranges here (i.e. "C22:C2000", "E22:E2000", ...)
    aColumn = Array("C", "D")               ' <-- Set the columns here (i.e. "F", "G", ...)

    ' Loop through all sheets in the workbook and copy details in Combined sheet
    For Each oWS In ThisWorkbook.Worksheets
        If oWS.Name <> "Combined" Then
            With oWS
                oComWS.Range("A" & iLR).Value = .Range("A2").Value
                oComWS.Range("B" & iLR).Value = .Range("B2").Value

                For iC = LBound(aMyRange) To UBound(aMyRange)
                    aCleanArray = CleanUpArray(.Range(aMyRange(iC)).Value)
                    oComWS.Range(aColumn(iC) & iLR & ":" & aColumn(iC) & (iLR + UBound(aCleanArray))).Value = Application.Transpose(aCleanArray)
                Next
            End With
            iLR = oComWS.Range(aColumn(0) & oComWS.Rows.Count).End(xlUp).Row + 1
        End If
    Next

End Sub

Function CleanUpArray(aIncomigArray As Variant) As Variant
    Dim aTemp() As Variant
    Dim iC As Long

    ReDim aTemp(0 To 0)

    For iC = LBound(aIncomigArray) To UBound(aIncomigArray)
        If Not IsEmpty(aIncomigArray(iC, 1)) Then
            aTemp(UBound(aTemp)) = aIncomigArray(iC, 1)
            ReDim Preserve aTemp(UBound(aTemp) + 1)
        End If
    Next

    ReDim Preserve aTemp(UBound(aTemp) - 1)
    CleanUpArray = aTemp

End Function

希望对您有所帮助

有没有一种快速的方法可以使用 VBA 或 R 重新格式化和编译 Excel 中的奇数数据？

Is there a fast way to re-format and compile odd data in Excel using VBA or R?

excel

vba

r

merging-data

reformatting