Flattening data from oddly shaped "tables"

Question

I have a spreadsheet with hundreds of table broken out by WBS, with odd formatting.

Beginning Format

What I want it to look like

I found a solution in which the starting tables are better organized into a summary table with headers at top: How to "flatten" or "collapse" a 2D Excel table into 1D?

The macro I used works for two tables but uses absolute references to copy and transpose the data. It's very rough, but I've included below to show that I attempted.

The column (HRS, P, etc) and row (AL, Con, IH, etc) headings don't appear to change, so I assume I need something that will find a WBS and grab this information. Another issue is that some of the tables have extra Column headings before the Travel row (see second table in screenshot).

How do I go about writing something that will search for a WBS and record the flattened data, without referencing the specific cells?

Let me know if my question is poorly worded or if more information is needed.

Code from first macro:

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

At risk of sounding not so nice, I would suggest learning how to write VBA. Recording macros can be a great place to start, but you need to learn the basic concepts of VBA and how to type it. — Kyle, Jun 23 '16 at 16:53
Recording macros and going back to the code, understanding it, and customizing it is a great way to learn VBA. In order to add flexibility and not hardcording anything you'll want to looking into looping through rows/cols and look for specific strings, ie. "WBS" A quick search for "loop through each row in excel vba" in Google landed me to another thread http://stackoverflow.com/questions/1463236/loop-through-each-row-of-a-range-in-excel — Steven Chang, Jun 23 '16 at 17:05

Chris Slade · Answer 1 · 2016-06-24T13:10:40.567

I'm assuming that the tables are all of the same size and relative offset to the WBS keyword. I'm also assuming that the row "Travel" isn't needed in the final output, and the subtotals will be recalculated if needed.

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

I'll leave it to you to ensure that the table numbers are correct. And I'd avoid 'Select' like the plague for this sort of thing, it'll only slow down the code.

Flattening data from oddly shaped "tables"

Beginning Format

What I want it to look like

1 Answers1