Question

我有一个电子表格，其中有数百个表由WBS分解，格式奇怪。

开始格式

我希望它看起来像什么

我找到了一个解决方案，其中将起始表更好地组织到一个摘要表中，标题位于顶部： How to "flatten" or "collapse" a 2D Excel table into 1D?

我使用的宏适用于两个表，但使用绝对引用来复制和转置数据。这非常粗糙，但我在下面列出了我尝试过的事情。

列（HRS，P等）和行（AL，Con，IH等）标题似乎没有变化，因此我假设我需要一些可以找到WBS并获取此信息的内容。另一个问题是，某些表在Travel行之前有额外的列标题（请参见屏幕截图中的第二个表）。

如何在不引用特定单元格的情况下编写可搜索WBS并记录展平数据的内容？

如果我的问题措辞不当或需要更多信息，请告诉我。

第一个宏的代码：

Attribute VB_Name = "Module2"
Sub flatten_data()
Attribute flatten_data.VB_ProcData.VB_Invoke_Func = " \n14"
'
' flatten_data Macro
'

'
    Range("B1").Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A1:A42"), Type:=xlFillDefault
    Range("A1:A42").Select
    ActiveSheet.Previous.Select
    Range("F3:K3").Select
    Selection.Copy
    ActiveSheet.Next.Select
    ActiveWindow.SmallScroll Down:=-45
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False
    Selection.Copy
    Range("B7").Select
    ActiveSheet.Paste
    Range("B13").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=6
    Range("B19").Select
    ActiveSheet.Paste
    ActiveWindow.SmallScroll Down:=9
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("B19:B42"), Type:=xlFillDefault
    Range("B19:B42").Select
    ActiveSheet.Previous.Select
    Range("C6").Select
    Selection.Copy
    ActiveSheet.Next.Select
    Range("C16").Select
    ActiveWindow.SmallScroll Down:=-54
    Range("C1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("C1:C6"), Type:=xlFillDefault
    Range("C1:C6").Select
    Selection.Copy
    ActiveSheet.Previous.Select
    Range("C7").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("C7:C12").Select
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Range("C8").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("C13:C18").Select
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Range("C9").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("C19:C24").Select
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Range("C10").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("C25:C30").Select
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Range("C11").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    ActiveWindow.SmallScroll Down:=12
    Range("C31:C36").Select
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Range("C12").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("C37:C42").Select
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Range("F6:K6").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    ActiveWindow.SmallScroll Down:=-33
    Range("D1").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("D7").Select
    ActiveSheet.Previous.Select
    Range("F7:K7").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F8:K8").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D13").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F9:K9").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D19").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F10:K10").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D25").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveWindow.SmallScroll Down:=18
    ActiveSheet.Previous.Select
    Range("F11:K11").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D31").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F12:K12").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D37").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("B16").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("A43:A84").Select
    ActiveSheet.Paste
    Range("B1:B42").Select
    Range("B42").Activate
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=24
    Range("B43").Select
    ActiveSheet.Paste
    Range("C1:C42").Select
    Range("C42").Activate
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll Down:=27
    Range("C43").Select
    ActiveSheet.Paste
    ActiveSheet.Previous.Select
    Range("F21:K21").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D43").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F22:K22").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D49").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F23:K23").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D55").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F24:K24").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    ActiveWindow.SmallScroll Down:=12
    Range("D61").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F25:K25").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D67").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveWindow.SmallScroll Down:=21
    ActiveSheet.Previous.Select
    Range("F26:K26").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D73").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ActiveSheet.Previous.Select
    Range("F29:K29").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveSheet.Next.Select
    Range("D79").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
End Sub

Answer 1

我假设这些表与WBS关键字的大小和相对偏移量都相同。我还假设这一行＆＃34;旅行＆＃34;在最终输出中不需要，如果需要，将重新计算小计。

Option Explicit

Sub Flatten_Data()

Dim wb As Workbook
Dim ws As Worksheet
Dim GCell As Range
Dim TableCell As Range
Dim TotalTables As Integer
Dim TableNumber As Integer
Dim TableRow As Integer
Dim TableColumn As Integer
Dim ColumnHeader(6) As String
Dim RowHeader(7) As String

ColumnHeader(1) = "HRS"
ColumnHeader(2) = "P"
ColumnHeader(3) = "OH"
ColumnHeader(4) = "G"
ColumnHeader(5) = "C"
ColumnHeader(6) = "F"
RowHeader(1) = "AL"
RowHeader(2) = "Con"
RowHeader(3) = "IH"
RowHeader(4) = "Mat"
RowHeader(5) = "OD"
RowHeader(6) = "SUB"
RowHeader(7) = "Trav"

Set wb = Workbooks("Book1") ' or whatever sheet holds the source data
Set ws = Worksheets("Sheet1")   ' or whatever sheet you want to copy the flattened data to
With wb
    With ws
        Set GCell = .Range("A:A")
        TotalTables = Application.WorksheetFunction.CountIf(GCell, "WBS")
        Set GCell = .Cells.Find("WBS", .Cells(1048576, 1)) ' looks for "WBS" and ensures that it finds one in A1 if it exists
        For TableNumber = 1 To TotalTables
            For TableRow = 1 To 7
                For TableColumn = 1 To 6
                    Worksheets("Sheet2").Cells(TableColumn + (TableRow - 1) * 6 + (TableNumber - 1) * 42, 4) = GCell.Offset(4 + TableRow, 4 + TableColumn).Value
                    Worksheets("Sheet2").Cells(TableColumn + (TableRow - 1) * 6 + (TableNumber - 1) * 42, 3) = RowHeader(TableRow)
                    Worksheets("Sheet2").Cells(TableColumn + (TableRow - 1) * 6 + (TableNumber - 1) * 42, 2) = ColumnHeader(TableColumn)
                    Worksheets("Sheet2").Cells(TableColumn + (TableRow - 1) * 6 + (TableNumber - 1) * 42, 1) = "1." & TableNumber
                Next TableColumn
            Next TableRow
            Set GCell = .Cells.FindNext(GCell)
        Next TableNumber
    End With
End With

End Sub

我会留给您，以确保表格编号正确无误。我会避免选择＆＃39;就像这种事情的瘟疫一样，它只会减慢代码的速度。

从奇形怪状的“表格”中整理数据

开始格式

我希望它看起来像什么

1 个答案: