Hi Tom,
Here it all is.
Sub HPaste()
ActiveCell.Offset(-1, 0).Select
ActiveSheet.Paste
End Sub
Sub HSelect()
ActiveCell.Offset(1, 0).Select
ActiveCell.Copy
Sheets("Headings").Select
Range("j1").Select
ActiveSheet.Paste
Columns("i:i").Select
Selection.Find(What:=Range("j1").Value, After:=ActiveCell, LookIn _
:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 2).Select
ActiveCell.Copy
End Sub
Sub SubHSelect()
Call InsertR
ActiveCell.Offset(1, 0).Select
ActiveCell.Copy
Sheets("Headings").Select
Range("b1").Select
ActiveSheet.Paste
Columns("a:a").Select
Selection.Find(What:=Range("b1").Value, After:=ActiveCell, LookIn _
:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 2).Select
ActiveCell.Copy
End Sub
Sub RunPrintProgram()
Dim a As Variant
Dim x As Integer
Call UnhideSheets
Call Pastevalues
a = Array("Summary all Programs - P&L", "Corporate Services Summary", "10-70 Corporate Services", _
"10-71 Promotions", "10-77 AAV Resources", "10-78 Dementia Awareness Week", "Support Services Summary", _
"20-29 Memory Lane Cafes", "20-80 Administration", "20-86 Metro & Gippsland", _
"20-87 Rural", "20-88 Gateways", "20-28 Early Stage")
For x = LBound(a) To UBound(a)
Sheets(a(x)).Select
Range("a9").Select
Do While ActiveCell.Value <> Empty
10 If ActiveCell.Offset(0, 1).Value <> Empty Then GoTo 15
If ActiveCell.Offset(0, 2).Value <> Empty Then GoTo 15
If ActiveCell.Offset(0, 3).Value <> Empty Then GoTo 15
If ActiveCell.Offset(0, 4).Value <> Empty Then GoTo 15
Call Deleterow
GoTo 20
15 ActiveCell.Offset(1, 0).Select
20 Loop
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> Empty Then GoTo 10
Range("a9").Select
30 Call InsertR
Call HSelect
Sheets(a(x)).Select
Call HPaste
' insert extra subtotals here
If ActiveCell.Value = " 51 TRAVEL & ACCOMMODATION" Then
ActiveCell.Offset(1, 0).Select
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
If ActiveCell.Value = " 511 NON AAV FLEET EXPENSES" Then GoTo 40
On Error GoTo 31
Cells.Find(What:="511", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
GoTo 40
31 On Error GoTo 32
Cells.Find(What:="512", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
GoTo 40
32 On Error GoTo 40
Cells.Find(What:="513", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
GoTo 40
ElseIf ActiveCell.Value = " 54 OTHER OFFICE EXPENSES" Then
ActiveCell.Offset(1, 0).Select
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
If ActiveCell.Value = " 541 PHOTOCOPIER COSTS" Then GoTo 33
If ActiveCell.Value = " 543 FURNITURE" Then GoTo 34
If ActiveCell.Value = " 545 COMPUTERS" Then GoTo 40
On Error GoTo 33
Cells.Find(What:="541", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
33 On Error GoTo 34
Cells.Find(What:="543", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
34 On Error GoTo 40
Cells.Find(What:="545", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
GoTo 40
ElseIf ActiveCell.Value = " 56 PROGRAM DELIVERY COSTS" Then
On Error GoTo 40
Cells.Find(What:="569", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
GoTo 40
ElseIf ActiveCell.Value = " 57 PROMOTIONAL COSTS" Then
On Error GoTo 35
Cells.Find(What:="575", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
35 On Error GoTo 36
Cells.Find(What:="576", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
36 On Error GoTo 40
Cells.Find(What:="577", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
Call SubHSelect
Sheets(a(x)).Select
Call HPaste
GoTo 40
End If
40 Cells.Find(What:="Total", After:=ActiveCell, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, _
SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = Empty Then ActiveCell.Offset(3, 0).Select
If ActiveCell.Value = "Total Salary Expenses" Then Call TotSal
If ActiveCell.Value = "Total Non Salary Expenses" Then GoTo 50
GoTo 30
50 Next x
' ActiveWorkbook.Close savechanges:=False
End Sub
Sub Deleterow()
Selection.EntireRow.Select
Selection.Delete
End Sub
Sub InsertR()
Selection.EntireRow.Select
Selection.Insert Shift:=x1Up
End Sub
Sub UnhideSheets()
Dim wsSheet As Worksheet
For Each wsSheet In ActiveWorkbook.Worksheets
wsSheet.Visible = xlSheetVisible
Next wsSheet
End Sub
Sub Pastevalues()
Sheets("CAPEX BUDGET").Select
ActiveWindow.ScrollWorkbookTabs Position:=xlLast
Sheets(Array("CAPEX BUDGET", "summary program results", "Income Summary", _
"Reconciliation", "Department Summary", "Summary all Programs - P&L", _
"Corporate Programs", "Corporate Services Summary", "10-70 Corporate Services", _
"10-71 Promotions", "10-77 AAV Resources", "10-78 Dementia Awareness Week", _
"10-72 Program Establishment", "Support Programs", "Support Services Summary", _
"20-29 Memory Lane Cafes", "20-80 Administration", "20-86 Metro & Gippsland", _
"20-87 Rural", "20-88 Gateways", "20-28 Early Stage", _
"20-81 Dementia Caring Project", "20-85 Telephone & Infrastructur", "20-XX Blank" _
, "Education Programs")).Select
Sheets("CAPEX BUDGET").Activate
Sheets(Array("Education - Summary", "30-51 Traineeships", _
"30-56 Dementia Essentials", "30-57 Dem. Train. Study Centre", _
"30-90 Administration", "30-91 HACC ", "30-93 Fee for Service", "30-94 AA Quals", _
"30-99 NDSP - Ed'n & Training", "30-53 RAP4", "30-50 AAA Website", _
"30-60 Primary Schools Project", "40-75 Fundraising", _
"40-75 Fundraising Sub-Programs", "Strat. Policy & Proj. Programs", _
"Strat. Policy & Project Summary", "50-24 Nat Resources", "50-35 MyM National", _
"50-74 Dementia Policy & Project", "50-76 Collab. Research Centre", _
"50-79 Consultancies", "50-89 D&MCC's", "50-92 Library", "50-97 AAV Website", _
"50-XX National Project")).Select Replace:=False
Sheets("50-36 MyM Victoria").Select Replace:=False
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub
Private Sub Boldhead()
'bold heading with no underline
With Selection.Font
.Name = "Arial"
.Size = 10
.Bold = True
.Underline = xlUnderlineStyleNone
End With
End Sub
Sub TotSal()
ActiveCell.Offset(4, 0).Select
Call InsertR
ActiveCell.Value = "Non Salary Expenses"
Call Boldhead
ActiveCell.Offset(1, 0).Select
End Sub