0

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

附有一张图片，它是每张纸的格式示例 - 它包含所有单元格，但不包含任何实际数据。实际上，有很多数据 - 有些工作表有超过 1000 行。

我尝试使用 R 中的函数将所有工作表作为单独的数据框读取，以便我可以合并它们，但我无法让它工作。然后我尝试使用 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 会将正确的列和范围复制并粘贴到仅适用于工作表 2 的新创建的工作表中。我尝试集成其他代码片段，以便这将遍历工作簿中的所有工作表并将数据粘贴到之前添加的最后一行下方但我无法让它工作。我也希望能够添加一列，其中包含从中复制数据的工作表的名称。

如果有人可以使用 R 或 VBA 帮助我，我将不胜感激。

这是每张纸的格式示例

这是我希望主编译表看起来像的示例

4

1 回答 1

0

试试下面的代码

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

希望这可以帮助

于 2020-06-11T10:17:36.510 回答