I'm very new to VBA (as of this morning), so excuse my ignorance. I have a few hundred Excel workbooks, all formatted exactly the same way (just with different text). I'm trying to both format and delete a few sheets within the workbooks (the same for alL).
I recorded a macro that works fine when applied individually, but I'm getting a runtime error when I try to run this as a means of mass format:
Sub LoopFiles()
Dim MyFileName, MyPath As String
Dim MyBook As Workbook
MyPath = "I:\Academic Networks\All scorecard copies, 6.18.2015"
MyFileName = Dir(MyPath & "*.xlsm")
Do Until MyFileName = ""
Workbooks.Open MyPath & MyFileName
Set MyBook = ActiveWorkbook
Application.Run "Workbook1.xlsm!ScorecardMacro"
MyBook.Save
MyBook.Close
MyFileName = Dir
Loop
End Sub
I keep getting a runtime error (9) - Subscript out of range. Any thoughts?
Here's the formatting/deleting I'm trying to apply to all my workbooks (which works fine when applied to one workbook at a time:
Sub ScorecardMacro()
'
' Scorecard Macro
'
'
Sheets.Add
Sheets("Scorecard").Select
Range("D3:D36").Select
Selection.Copy
Sheets("Sheet1").Select
Range("B1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Scorecard").Select
Range("A3:A36").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Scorecard").Select
Range("F3:I36").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("B3").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Checklist").Select
Range("D4:D27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
ActiveWindow.ScrollColumn = 28
Range("AJ1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Checklist").Select
Range("A4:A27").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("AJ2").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Sheets("Additional Information").Select
Range("A4:B14").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("BH1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Sheets("Program Recommendations").Select
Range("A4:D21").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("BS1").Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
ActiveWindow.ScrollColumn = 1
Range("A2").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = ""
ActiveCell.FormulaR1C1 = _
"=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1,SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1)"
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A6"), Type:=xlFillDefault
Range("A2:A6").Select
Sheets("Program Recommendations").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Additional Information").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Scorecard").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Checklist").Select
ActiveWindow.SelectedSheets.Delete
End Sub
The error shows you are trying to access something that doesn't exist.
Since you are deleting something, its better to do all you updates first, then do all the deletes in the end.
If you do some deletes in between and then update, there might be some values/sheets missing
You are referring to a named range called "filename":
"=MID(CELL(""filename""),SEARCH(""["",CELL(""filename""))+1,SEARCH(""]"",CELL(""filename""))-SEARCH(""["",CELL(""filename""))-1)"
I suspect that name is not defined in the other workbooks.
Related
I'm a beginner, so any help is much appreciated, I want to combine this macro with the first code, but I don't know how to do that or where to put it.
this is the first code (it has a mistake in it, but I already have an answer on how to fix it, so it's alright):
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("inbd")
Dim wsDestination As Worksheet: Set wsDestination = Sheets("test")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A1:N" & LastRow).AutoFilter Field:=1, Criteria1:=Worksheets("test").Cells(1, 26).Value
ws.Range("f2:f" & LastRow).SpecialCells(xlCellTypeVisible).Copy Range("C6")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, "C").End(xlUp).Row + 1
wsDestination.Range("C" & DestinationRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws.Range("A1:N" & LastRow).AutoFilter Field:=1
End Sub
currently the first code filters and copies table data in the parameter that I want into another worksheet, but I need a more complex version of the copy so I recorded it in macro, which is super long and looks like this:
Sub Macro8()
'
' Macro8 Macro
'
'
Sheets("INBD").Select
Range("Table1[Description]").Select
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Description]").Select
ActiveSheet.Paste
Range("D18").Select
Sheets("INBD").Select
Range("Table1[Invoice Date]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Invoice '#]").Select
ActiveSheet.Paste
Sheets("INBD").Select
Range("Table1[Invoice '#]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Invoice '#]").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("INBD").Select
Range("Table1[HS Code]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[HS Code]").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("INBD").Select
Range("Table1[Unit]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[M. Unit]").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("Table19[Description]").Select
Application.CutCopyMode = False
Selection.Copy
Range("E13").Select
ActiveSheet.Paste
Sheets("INBD").Select
Range("Table1[QTY]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[QTY]").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Sheets("INBD").Select
Range("Table1[Unit Price]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Unit Price]").Select
ActiveSheet.Paste
Sheets("INBD").Select
Range("Table1[Curr.]").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheet1").Select
Range("Table19[Curr]").Select
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Rows("13:22").Select
Rows("13:22").EntireRow.AutoFit
Selection.RowHeight = 30
Application.CutCopyMode = False
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
What this does is that it copies values into a table, into specific columns, below the table I wrote in a bunch of stuff and made the color of the font white, so that when it copies, the table moves the cells down hence not altering anything below the table and leaves some space in between. After this I'm going to record a macro which deletes all rows in the table and any other data in the table to clear the document for a new entry.
One solution to combine two Macros would be just to type everything from the second Macro between the first and last line and paste in where you need its execution in the first code.
The other solution would be to "Call" the second Macro from the first Code by simply typing
Call Macro8
In your example :
Sub foo()
Dim ws As Worksheet: Set ws = Sheets("inbd")
Dim wsDestination As Worksheet: Set wsDestination = Sheets("test")
LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
ws.Range("A1:N" & LastRow).AutoFilter Field:=1, Criteria1:=Worksheets("test").Cells(1, 26).Value
ws.Range("f2:f" & LastRow).SpecialCells(xlCellTypeVisible).Copy Range("C6")
DestinationRow = wsDestination.Cells(wsDestination.Rows.Count, "C").End(xlUp).Row + 1
wsDestination.Range("C" & DestinationRow).PasteSpecial xlPasteValues
Application.CutCopyMode = False
ws.Range("A1:N" & LastRow).AutoFilter Field:=1
Call Macro8 ' Or Copy Paste the whole other code here
End Sub
I still strongly advise to follow the links from the comments of Foxfire And Burns And Burns about How to avoid using Select in Excel VBA.
Application.run ("macro8") <-is what I needed, I appreciate the advice though, I don't really have any knowledge in coding, but I will try to avoid using select if i can.
I am trying to copy and paste certain cells that are not in the same column or row and paste them in Specific columns (it will be the same columns everytime). Once each entry is done, I want the next set of entries to paste on the next available row. The first set of code for Paste_NextRow() was ran as a macro and this was the code that was returned. The ranges I selected have formulas in them that will have different values each month. I am pasting them in a row with headers in row A. The second set of code for LastRow() I found this online and it will return the last row that is empty. I'm unsure how to utilize the second set of code to paste in the next available row. If you need additional context in order to help modify the code please let me know. Thanks. I've edited the text to show the code accordingly.
Sub Paste_NextRow()
'
' Paste_NextRow Macro
'
'
Sheets("SUMMARY DATA SHEET").Select
Range("F3").Select
Selection.Copy
Sheets("Invoice Number").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Select
Range("F2").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Invoice Number").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Select
Range("B4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Invoice Number").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Select
Range("F4").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Invoice Number").Select
Range("D2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Select
Range("F5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Invoice Number").Select
Range("E2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A3").Select
End Sub
Sub LastRow()
NextRow = ThisWorkbook.Sheets("Invoice Number").Cells(Rows.Count, 2).End(xlUp).Row + 1
End Sub
Here is a quick rewrite setting a variable (called lastRow) to the last row in your invoice number tab.
Sub Paste_NextRow()
'
' Paste_NextRow Macro
'
'
'Get the last used row into a variable
Dim lastRow as Long
lastRow = ThisWorkbook.Sheets("Invoice Number").Cells(Rows.Count, 2).End(xlUp).Row + 1
'Copy Summary Data Sheet F3
Sheets("SUMMARY DATA SHEET").Range("F3").Copy
'And paste it into the last row (column F) of Invoice Number sheet
Sheets("Invoice Number").Range("F" & LastRow).Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Use similar logic for the remaining cells
Sheets("SUMMARY DATA SHEET").Range("F2").Copy
Sheets("Invoice Number").Range("C" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Range("B4").Copy
Sheets("Invoice Number").Range("B" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Range("F4").Copy
Sheets("Invoice Number").Range("D" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("SUMMARY DATA SHEET").Range("F5").Copy
Sheets("Invoice Number").Range("E" & lastRow).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
You'll see that there are no .Select happening here since Selecting a sheet or a cell is something a human does. There really isn't a need to do that in VBA where instead we can just specify exactly what we want to copy and where we want to paste it.
While this is cleaned up, it's still a little cumbersome to just copy and paste VALUES around the workbook. It uses the clipboard and has multiple statements for each copy/paste.
Instead we can just set the value of one cell equal to the value of another cell:
Sub Paste_NextRow()
'
' Paste_NextRow Macro
'
'
'Get the last used row into a variable
Dim lastRow as Long
lastRow = ThisWorkbook.Sheets("Invoice Number").Cells(Rows.Count, 2).End(xlUp).Row + 1
Sheets("Invoice Number").Range("F" & LastRow).Value = Sheets("SUMMARY DATA SHEET").Range("F3").value
Sheets("Invoice Number").Range("C" & lastRow).value = Sheets("SUMMARY DATA SHEET").Range("F2").value
Sheets("Invoice Number").Range("B" & lastRow).Value = Sheets("SUMMARY DATA SHEET").Range("B4").value
Sheets("Invoice Number").Range("D" & lastRow).Value = Sheets("SUMMARY DATA SHEET").Range("F4").value
Sheets("Invoice Number").Range("E" & lastRow).Value = Sheets("SUMMARY DATA SHEET").Range("F5").value
End Sub
Lastly, typing out those worksheet names over and over again is cumbersome. We can use a couple of variables to hold the two worksheets we care about. This is nice if you ever want to change worksheet names as you only have one place in the code to make the change:
Sub Paste_NextRow()
'
' Paste_NextRow Macro
'
'
'Set some variables to hold our worksheets
Dim wsCopy as Worksheet
Dim wsPaste as Worksheet
Set wsCopy = Sheets("SUMMARY DATA SHEET")
Set wsPaste = Sheets("Invoice Number")
'Get the last used row into a variable
Dim lastRow as Long
lastRow = ThisWorkbook.Sheets("Invoice Number").Cells(Rows.Count, 2).End(xlUp).Row + 1
'Copy values over
wsPaste.Range("F" & LastRow).Value = wsCopy.Range("F3").value
wsPaste.Range("C" & lastRow).value = wsCopy.Range("F2").value
wsPaste.Range("B" & lastRow).Value = wsCopy.Range("B4").value
wsPaste.Range("D" & lastRow).Value = wsCopy.Range("F4").value
wsPaste.Range("E" & lastRow).Value = wsCopy.Range("F5").value
End Sub
A few times a day I receive a file. I'm trying to automate it as much as possible and one part would include having the macro that lets you select a file to vlookup into (the file name is different every time). My macro runs, but for some reason it prompts you to select your file 3 times. I've tried a few variations on the code, but nothing worked. Does anyone have any insight as to why? It is prompting once when first opening the file, once when filling in the first cell with the formula, and again when the macro fills down column with the vlookup formula. I've pasted the relevant part below:
Dim MyFile As String
MyFile = Application.GetOpenFilename
Set firstWB = ActiveWorkbook
Set mySheet = ActiveSheet
Set wbLookup = Workbooks.Open(MyFile)
firstWB.Activate
mySheet.Range("T2").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-18],'[wbLookup]tempemail'!R2C2:R123C20,19,0)"
Range("S1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(0, 1).Select
Range(Selection, Selection.End(xlUp)).Select
Selection.FillDown
Columns("t:t").EntireColumn.AutoFit
Columns("T:T").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
wbLookup.Close False
Range("U1").Select
ActiveCell.FormulaR1C1 = "=NOW()"
Range("U1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("u:u").EntireColumn.AutoFit
End Sub
Thanks!
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-18],'[wbLookup]tempemail'!R2C2:R123C20,19,0)"
This will not work unless wbLookup is literally the name of your file. Excel sees this and prompts you for the actual name.
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-18],'[" & wbLookup.Name & "]tempemail'!R2C2:R123C20,19,0)"
might work better
This:
Columns("T:T").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
...could be replaced by this:
Columns("T:T").Value = Columns("T:T").Value
A lot of selecting/activating is unneeded and is better avoided: How to avoid using Select in Excel VBA
I am slowly learning VBA in Excel on my own so I'm sure this code can be picked a part. Basically users fill this area with info and click a button that in the background copies the data they populate, opens a new workbook and pastes it in the next open row. There are many users, and for some it works, for others it runs with no error but their info is not pasted in the new. location. Most of the stuff at the end is just reformatting, but I didn't want to take it out in case it could be a part of the problem.
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
Sub FF_Temp_Upload()
'
' FF_Temp_Upload Macro
'
Application.ScreenUpdating = False
Dim Workbk As Workbook
Set Workbk = ThisWorkbook
Dim LR As Long
Dim Cell As Long
Dim Ret As String
LR = Range("B" & Rows.Count).End(xlUp).Row
Ret = IsWorkBookOpen("Location of the 2nd workbook/OVS Upload Template.xlsx")
If Ret = True Then
MsgBox "Template is currently being updated elsewhere. Please try again."
Exit Sub
Else
Workbooks.Open FileName:= _
"Location of the 2nd workbook/OVS Upload Template.xlsx"
End If
Workbk.Activate
Range("A2:C" & LR).Select
Selection.Copy
Windows("OVS Upload Template.xlsx").Activate
If Range("A2") = "" Then
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Else
Range("A1").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
Workbk.Activate
Range("H2:H" & LR).Select
Application.CutCopyMode = False
Selection.Copy
Windows("OVS Upload Template.xlsx").Activate
If Range("L2") = "" Then
Range("L2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Else
Range("L2").Select
Selection.End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End If
ActiveSheet.Range("$A$1:$M$100000").RemoveDuplicates Columns:=1, Header:=xlYes
LR = Range("B" & Rows.Count).End(xlUp).Row
Range("B2:B" & LR) = "=text(left(A2,8),""00000000"")"
Range("B2:B" & LR).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("C2:C" & LR) = "=""DCG""&MID(A2,9,4)"
Range("C2:C" & LR).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("D2:D" & LR).Select
Selection.Formula = "DT"
Range("I2:I" & LR).Select
Selection.Formula = "730"
Range("M2:M" & LR).Select
Selection.Formula = "MAJOH73"
ActiveWorkbook.Save
ActiveWindow.Close
Workbk.Activate
MsgBox "Articles Uploaded"
End Sub
You do not refer to Worksheets anywhere in your code. Thus, for some users, it works and for some it does not.
For those who works - their Excel file was saved with the correct Worksheet selected.
For those who does not work - their Excel file was saved with wrong Worksheet selected. Thus, when it is opened, the ActiveSheet is the wrong one and the code works there.
To fix it (quick and dirty) rewrite your code, refering the worksheet like this:
Worksheets("MyWorksheet").Range("$A$1:$M$100000").RemoveDuplicates Columns:=1
Then try to avoid Selection and ActiveSheet - How to avoid using Select in Excel VBA. At the end, each range or cell should be with refered Worksheet. Like this:
With Worksheets("MyName")
.Range("D2:D" & LR).Formula = "DT"
.Range("I2:I" & LR).Formula = "730"
.Range("M2:M" & LR).Formula = "MAJOH73"
End With
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
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.