Flattening data from oddly shaped "tables" - vba

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

Answer 1

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.