Integrating A Status BarIn VBA Code

B

BDBJ123

New Member
Joined
Dec 16, 2015
Messages
11
I am struggling to integrate a status bar into my VBA code below and make it work.

Does anyone have any ideas on how to fit this code in to the below code and make it work:

I believe the progress bar code should follow this format:

Code: 
<code>For Each ws In Worksheets </code><code> ' some code here
            wsi = ws.Index ' Capture index to worksheet
' some more code here
    For r = 1 To RowMax
        For c = 1 To ColMax
' even more code here
        PctDone =  (RowMax * ColMax * wsi-1 + r * c)/ (RowMax * ColMax * Worksheets.Count)
        Next c
' yet more code here
    Next r
' and finally code here
 Next ws

However I don't know how to integrate this into the below code so that it works:

Code: 
Private Sub CommandButton1_Click()



Dim Firstrow As Long
Dim Lastrow As Long

Dim MyFile1 As Variant
Dim ActualDate As Date

       MyFile1 = Application.GetOpenFilename


       If MyFile1 = False Then Exit Sub


        Workbooks.Open Filename:=MyFile1

    ActiveWindow.View = xlNormalView


Range("A1").Select

Dim CostsTo As String


UserForm1.Hide


Do
Cells.Find(What:="Project Details", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate



Firstrow = ActiveCell.Row()

Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
Lastrow = ActiveCell.Row()

Rows(Firstrow & ":" & Lastrow).Select

    Selection.Cut
    Sheets.Add After:=Sheets(Sheets.Count)
    Range("A3").Select
    ActiveSheet.Paste

Worksheets(1).Activate
Range("A1").Select



On Error GoTo Errorhandler1
Loop

Errorhandler1:



Worksheets(1).Activate
Range("A1").Select

Dim Title As String

Title = ActiveCell
''''msgbox Title

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Activate

    Cells.Select
    Range("A1").Activate
    Selection.ColumnWidth = 15
    Range("A1").Select

'deletes project end date

Cells.Find(What:="Project End Date", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveCell.Offset(0, 1).Activate
    Selection.ClearContents
    ActiveCell.Offset(1, 0).Activate
    Selection.ClearContents
    ActiveCell.Offset(0, -1).Activate
    Selection.ClearContents

'Moves % spend
Range("D7:D8").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("E7:E8").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("D7").Select
    Selection.FillDown
    Range("E7").Select
    Selection.FillDown
    
'adds budget spend %

Range("D6").Select
ActiveCell = "% Budget Spent"
Range("E14").Select
SpentPCent = ActiveCell
Range("E6").Select
Selection.NumberFormat = "0.00"
ActiveCell = SpentPCent
Range("D7").Select
ActiveCell = "% Time Elapsed"
Range("E9").Select
TimeElap = ActiveCell
Range("E7").Select
Selection.NumberFormat = "0.00"
ActiveCell = TimeElap
Range("D9").Select
Selection.ClearContents
ActiveCell.Offset(0, 1).Activate
Selection.ClearContents
Range("D8").Select
ActiveCell = "Top Task Number"
Range("B12").Select
TopTask = ActiveCell
Range("E8").Select
ActiveCell = TopTask
    
'deletes task info box
Rows("10:16").Select
Selection.Delete Shift:=xlUp
Range("A10").Select

'''msgbox ""


Dim ProNum As String

Cells.Find(What:="Project Number", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 1).Select
ProNum = ActiveCell
''''msgbox ProNum

'Roles up EC non Staff budgets and spend

 '   Cells.Find(What:="funder", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
  '      :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
   '     False, SearchFormat:=False).Activate

'ActiveCell.Offset(0, 1).Activate
'If ActiveCell = "European Commission" Then

 '   Cells.Find(What:="Expenditure Category", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
  '      :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
   '     False, SearchFormat:=False).Activate
        
'Do Until ActiveCell = "Top Task Total"
'ActiveCell.Offset(1, 0).Activate
'If ActiveCell <> "Other Direct Costs" Then '''msgbox "what next?"


'Loop
'End If


'deletes rows where budget and actuals are zero

Cells.Find(What:="Funds Available", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select
''''msgbox ActiveCell

''''msgbox "stop"

Dim RemoveCell1
Dim RemoveCell2


Do Until ActiveCell.Offset(0, -4) = ""
RemoveCell1 = ActiveCell.Offset(0, -4)
RemoveCell2 = ActiveCell.Offset(0, -3)
If RemoveCell1 + RemoveCell2 = "0" Then Selection.EntireRow.Delete: ActiveCell.Offset(-1, 0).Select
ActiveCell.Offset(1, 0).Select
Loop

'adds subtotal
''''msgbox ""

Dim EndCell As String
Dim StartCell As String

Range("A1").Select
Cells.Find(What:="Task Cost Summary Report", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
''''msgbox ""
ActiveCell.Offset(1, 0).Activate
StartCell = ActiveCell.Row()


    Cells.Find(What:="Funds Available", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Selection.End(xlDown).Select
''''msgbox ""

EndCell = ActiveCell.Row()
''''msgbox ""

Range("B" & StartCell & ":H" & EndCell - 1).Select
    
        Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
        7), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    
''''msgbox ""
    
Range("A1").Select
Cells.Find(What:="Grand Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Rows(ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
'''msgbox ""

'WAS HERE
'makes subtotal bold
''msgbox "sub bold"
Range("A1").Select
Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
''''msgbox ""
EndCell = ActiveCell.Row()
''msgbox StartCell
With Range("B" & StartCell & ":H" & EndCell + 1)
''msgbox EndCell
    Set C = .Find(What:="subtotal", LookIn:=xlFormulas)
    If Not C Is Nothing Then
       firstAddress = C.Address
       Do
            C.EntireRow.Font.Bold = True
            Set C = .FindNext(C)
        Loop While Not C Is Nothing And C.Address <> firstAddress
    End If
    
End With
''''msgbox ""
'adds %spent

Range("A1").Select
Cells.Find(What:="Funds Available", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "% Spent"
ActiveCell.Offset(0, -1).Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

Range("A1").Select
'Cells.Find(What:="All Total", After:=ActiveCell, LookIn:=xlFormulas, _
'LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'MatchCase:=False, SearchFormat:=False).Activate

'ActiveCell.Offset(0, 6).Select
'Selection.Copy
'ActiveCell.Offset(0, 1).Select
'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
 '       SkipBlanks:=False, Transpose:=False

    Columns("I:I").Select
    Selection.NumberFormat = "0.00%"
    Selection.NumberFormat = "0%"
    


Range("A1").Select
Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select

Do Until ActiveCell.Offset(0, -5) = ""
''''msgbox "Pause"


Dim Bnumber As Integer
Bnumber = 1
On Error Resume Next
''''msgbox Err.Number
If ActiveCell.Offset(0, -7) <> " " Or ActiveCell.Offset(0, -4) <> "0" Or ActiveCell.Offset(0, -5) <> "0" Then

'If Err.Number > 0 Then
''''msgbox Err.Number
On Error Resume Next
If ActiveCell.Offset(0, -5) = 0 Then
ActiveCell = ActiveCell.Offset(0, -2) / Bnumber
Else:
ActiveCell = ActiveCell.Offset(0, -2) / ActiveCell.Offset(0, -5)
End If


End If
On Error GoTo 0


ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
Selection.Font.Bold = True

'inserts message about no budget
''''msgbox "stop"
Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select

Do Until ActiveCell.Offset(0, -5) = ""
If ActiveCell.Value = "" Then ActiveCell.Value = "No Budget"
ActiveCell.Offset(1, 0).Select
Loop

Columns("I:I").EntireColumn.AutoFit

Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Select
ActiveCell = "Balance Remaining"


Columns("H:H").EntireColumn.AutoFit


'hides RC savings lines and leaves total

'Dim RCHide As String
'Dim RCunhide As String

'RCHide = "RC RCUK Efficiency Savings"
'RCunhide = "RC RCUK Efficiency Savings Total"

Range("B1").Select


    Cells.Find(What:="Task Name", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
         
 
ActiveCell.Offset(1, 0).Select
 
Do Until ActiveCell.Value = "Top Task Total"

    If ActiveCell.Value = "RCUK" Then Selection.EntireRow.Hidden = True
    'If ActiveCell.Value = RCunhide Then Selection.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select

Loop
''''msgbox "stop"

'deletes summary
ActiveCell.Offset(1, 0).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete





 Range("I12").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Columns("I:I").EntireColumn.AutoFit
    Columns("F:F").EntireColumn.AutoFit
    Columns("G:G").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit

Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

  With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("I11").Select
    Range(Selection, Selection.End(xlToLeft)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge

Range("A11:I11").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

'  Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
'    Application.PrintCommunication = True

Range("A1").Select

''''msgbox "Tidy"


    Rows("3:3").Select
    Selection.UnMerge
    Range("C4:C9").Select
    Selection.UnMerge
Rows("9:12").Select

''''msgbox ""


    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    
    Range("D4:E9").Select
    Selection.Copy
    Range("A9").Select
    ActiveSheet.Paste
 '   Rows("9:9").Select
  '  Application.CutCopyMode = False
   ' Selection.Delete Shift:=xlUp
    'Rows("14:14").Select
    'Selection.Delete Shift:=xlUp
    Rows("3:3").Select
    Selection.UnMerge
    Range("C3:E14").Select
    

    
    Selection.ClearContents
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A3:B13").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A1").Select


 '   Selection.Delete Shift:=xlUp
    Range("B4:B13").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Dim SpendPercent As String
    Dim TimePercent As String
    
    Range("B11").Select
    ActiveCell.Value = Round(ActiveCell.Value, 0)
    Range("B12").Select
    ActiveCell.Value = Round(ActiveCell.Value, 0)
       
 
    
   

 Range("B11:B12").Select
      
    Selection.NumberFormat = "0"
    
    Range("B11").Select
    SpendPercent = ActiveCell
    
    ''''msgbox SpendPercent
    Selection.NumberFormat = "@"
    ActiveCell = SpendPercent & "%"

    Range("B12").Select
    TimePercent = ActiveCell
    
 '   '''msgbox SpendPercent
    Selection.NumberFormat = "@"
    ActiveCell = TimePercent & "%"
    
    
    
    
    
    'Round.ActiveCell
    
    
     Range("A14:B14").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A3:B13").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A15:I15").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Range("A15:I15").Select
    Selection.UnMerge
    Columns("D:H").Select
    Selection.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
    Range("A15:I15").Select
    Selection.Merge
    
    
    Range("A1").Select

'adds formulas to report

    Cells.Find(What:="Total Cost", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
      
        ActiveCell.Offset(1, 0).Activate
        
        Do Until ActiveCell = ""
        If Selection.Font.Bold = False Then
        ActiveCell.FormulaR1C1 = "=RC[-2]+RC[-1]"
        ActiveCell.Offset(1, 0).Activate
        Else: ActiveCell.Offset(1, 0).Activate
        End If
        Loop
    
    
    
    Cells.Find(What:="Balance Remaining", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
        ActiveCell.Offset(1, 0).Activate
        
        
        Do Until ActiveCell = ""
        If Selection.Font.Bold = False Then
        ActiveCell.FormulaR1C1 = "=RC[-4]-RC[-1]"
        ActiveCell.Offset(1, 0).Activate
        Else: ActiveCell.Offset(1, 0).Activate
        End If
        Loop
        
    
    Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
        ActiveCell.Offset(1, 0).Activate
        
        
        
        Do Until ActiveCell = ""
        If ActiveCell.Value = "No Budget" Then
        ActiveCell.Offset(1, 0).Activate
        Else: ActiveCell.FormulaR1C1 = "=RC[-2]/RC[-5]"
        ActiveCell.Offset(1, 0).Activate
        End If
        Loop
        
'inserts message about no budget
''''msgbox "stop"


Dim cel As Range
Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select

Do Until ActiveCell.Offset(0, -5) = ""

If ActiveCell.Offset(0, -5) = "0" Then ActiveCell = "No Budget"

ActiveCell.Offset(1, 0).Select
Loop


        
'subtotals bottom line

 Cells.Find(What:="Total Budget", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Dim Start As String
Dim Finish As String
Dim LineNos As String

Start = ActiveCell.Row()
''''msgbox Finish - Start

    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()
'''msgbox Finish

LineNos = Finish - Start + 1

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"

''''msgbox ""

 Cells.Find(What:="Actuals", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Start = ActiveCell.Row()
''''msgbox Start
    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"

Range("A1").Select
 Cells.Find(What:="Commitments", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Start = ActiveCell.Row()
''''msgbox Start
    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"

 Cells.Find(What:="Total Cost", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Start = ActiveCell.Row()
''''msgbox Start
    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"

Cells.Find(What:="Balance Remaining", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Start = ActiveCell.Row()
''''msgbox Start
    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"


ActiveWindow.View = xlNormalView



Range("A1").Select
ActiveCell = Title
ActiveCell.Font.Bold = True
Cells.Select
Selection.RowHeight = 15

Range("A1").Select


    Cells.Find(What:="Task Name", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
         
 
ActiveCell.Offset(1, 0).Select
 
Do Until ActiveCell.Offset(0, -1).Value = "Top Task Total"

    If ActiveCell.Value = "RCUK" Then Selection.EntireRow.Hidden = True
    'If ActiveCell.Value = RCunhide Then Selection.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select

Loop

'Columns("I:I").EntireColumn.AutoFit

'HERE
'Columns("B:I").EntireColumn.AutoFit


ActiveSheet.Name = ProNum

 Rows("13:13").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A13").Select
    ActiveCell.FormulaR1C1 = "Actuals As At"
    ActiveCell.Offset(0, 1).Value = DTPicker1
        
        Range("B13").Select
    Selection.ClearContents
    Selection.NumberFormat = "dd-mmm-yy"
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Range("A1").Select

        
  'adds Notes relating to end date
     Cells.Find(What:="announced end", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, 1).Select
ActiveCell.Name = "ABC"
     Cells.Find(What:="actuals as at", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, 1).Select
     ActiveCell.Name = "DEF"
     Range("ABC").Select
     
     'less than 6 months
         If (Range("ABC") - Range("DEF") < 183 And (Range("ABC") - Range("DEF") >= 91)) Then
                        ActiveCell.Interior.ColorIndex = 6 ' Color cell interior yellow
                        ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project is due to end within the next 6 months."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
                         
                         
        'less than 3 months
                        
         ElseIf (Range("ABC") - Range("DEF") <= 90 And (Range("ABC") - Range("DEF") >= 61)) Then
                         ActiveCell.Interior.ColorIndex = 44 'Color cell darker yellow/gold
                         ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project is due to end within the next 3 months."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
                        
       'Less than 2 months
       ElseIf (Range("ABC") - Range("DEF") <= 60 And (Range("ABC") - Range("DEF") >= 31)) Then
                         ActiveCell.Interior.ColorIndex = 45 'Cell color even darker yellow/light orange
                         
                        ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project is due to end within the next 2 months."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
                        
                            
     'Less than one month
     ElseIf (Range("ABC") - Range("DEF") <= 30 And (Range("ABC") - Range("DEF") >= 1)) Then
                         ActiveCell.Interior.ColorIndex = 46 'Cell color darkest orange
                        
                        ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project is due to end within the next month."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
                        
     'finished
    ElseIf Range("ABC") - Range("DEF") <= 0 Then
    ActiveCell.Interior.ColorIndex = 3  ' Color cell darkest red
    
     ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project has now finished."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
    
    
    
    Else
            ActiveCell.Select
  End If
  


Range("A1").Select



ActiveSheet.Name = ProNum







Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
'deletes summary
ActiveCell.Offset(1, 0).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete


Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(2, 0).Select
ActiveCell = "1. Salary commitments, as held on the HR or Payroll systems, are not included in this report."



Dim RowLocation As Long          'can hold over 32000 if over this many rows
Dim ColumnLocation As Integer   'columns won't exceed 256 in sheet
Dim CellLocation As String



Range("B1").Select
Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 7).Select

CellLocation = ActiveCell.Address

''msgbox CellLocation


Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(3, 0).Select
ActiveCell = "Please bear this in mind when reviewing the remaining balance total of:"
 
Dim CurrentCell As String


CurrentCell = ActiveCell.Row()
Range("A" & CurrentCell & ":D" & CurrentCell).Merge
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = "=" & CellLocation
Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"

 

''msgbox "OK?"


Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(4, 0).Select
ActiveCell = "2. Commitments - Costs that have been charged to the award, but are not yet actual e.g. a PO that has yet to be matched to an invoice."

Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(5, 0).Select
ActiveCell = "3. %Time Elapsed = Number of days since the start date of the award as a percentage of the duration of the award."


'msgbox "stop"

    Columns("C:C").Select
    Selection.ColumnWidth = 20
    
    Columns("E:E").Select
    Selection.ColumnWidth = 12
    
Next ws

'Application.ScreenUpdating = True

  
   ' ActiveWindow.Close
'End If
End Sub

Thanks.
</code>
 
Sort by date Sort by votes
Depends what you mean by a "status bar"

You already have access to Application.Statusbar, which is the bottom left hand side of the Excel screen, where it normally says "Ready"
Code: 
Sub reportStatus()
Dim i As Long
For i = 1 To 2000
    Application.StatusBar = i
Next i
Application.StatusBar = False
End Sub
You can write any text string here. Note that you have to switch it off ("FALSE") when finished

What looks slicker is a progress bar that pops up but which is more complex. It involves a VBA User Form with a blue rectangle, you set the width to 0 when your code starts and then expand it at key points. The key is understanding at which points you want to expand it. I'd suggest you stick to StatusBar if you just want to demonstrate progress as you can refer to worksheet names, rows, columns, % etc.
 
Upvote 0
OK-Thanks.

Yes a progress bar that pops up would be the ideal.

I've created a userform and got this code as an example from Microsoft:

Code: 
<code>Sub ShowUserForm()
    UserForm1.Show
End Sub

Sub Main()
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single

    Application.ScreenUpdating = False
    ' Initialize variables.
    Counter = 1
    RowMax = 100
    ColMax = 25

    ' Loop through cells.
    For r = 1 To RowMax
        For c = 1 To ColMax
            'Put a random number in a cell
            Cells(r, c) = Int(Rnd * 1000)
            Counter = Counter + 1
        Next c

        ' Update the percentage completed.
        PctDone = Counter / (RowMax * ColMax)

        ' Call subroutine that updates the progress bar.
        UpdateProgressBar PctDone
    Next r
    ' The task is finished, so unload the UserForm.
    Unload UserForm1
End Sub

Sub UpdateProgressBar(PctDone As Single)
    With UserForm1

        ' Update the Caption property of the Frame control.
        .FrameProgress.Caption = Format(PctDone, "0%")

        ' Widen the Label control.
        .LabelProgress.Width = PctDone * _
            (.FrameProgress.Width - 10)
    End With

    ' The DoEvents allows the UserForm to update.
    DoEvents
End Sub

But I don't know how to adapt this to mine above.

Basically the VBA code accesses data on another workbook and filters/splits/formats that data to individual tabs in another workbook but the size of this data varies month by month.

Would either a status bar/progress bar work effectively with the above process?
</code>
 
Upvote 0
The key bit is the UpdateProgressBar routine

You have several subs there, to load the form, unload the form etc. UpdateProgressBar requires a value to be passed to it which they've named pct as its a percentage between 0 and 100, and this changes the width of the shape as well as its caption

In your code you'd do whatever process you want, then at a point you think 1% of the process is complete, you could simply state
Code: 
UpdateProgressBar 1
which will run that routine

as a structured example within a loop
Code: 
Sub loop100()
Dim i As Integer

For i = 1 To 100
    ' your code here
    
    UpdateProgressBar i
Next i

End Sub
 
Upvote 0
Right I see so I know in my main code in Post #1 of this thread that it will go to next ws approximately 120 times.

So I will make a:

Code: 
Sub loop120() Dim i As Integer

For i = 1 To 120
    ' your code here
    
    UpdateProgressBar i
Next i

End Sub

So do I integrate that Sub loop120() somehow into my main code.


Code: 
Private Sub CommandButton1_Click()

Dim Firstrow As Long
Dim Lastrow As Long

Dim MyFile1 As Variant
Dim ActualDate As Date

       MyFile1 = Application.GetOpenFilename


       If MyFile1 = False Then Exit Sub


        Workbooks.Open Filename:=MyFile1

    ActiveWindow.View = xlNormalView


Range("A1").Select

Dim CostsTo As String


UserForm1.Hide


Do
Cells.Find(What:="Project Details", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate



Firstrow = ActiveCell.Row()

Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
Lastrow = ActiveCell.Row()

Rows(Firstrow & ":" & Lastrow).Select

    Selection.Cut
    Sheets.Add After:=Sheets(Sheets.Count)
    Range("A3").Select
    ActiveSheet.Paste

Worksheets(1).Activate
Range("A1").Select



On Error GoTo Errorhandler1
Loop

Errorhandler1:



Worksheets(1).Activate
Range("A1").Select

Dim Title As String

Title = ActiveCell
''''msgbox Title

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True

Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Activate

    Cells.Select
    Range("A1").Activate
    Selection.ColumnWidth = 15
    Range("A1").Select

'deletes project end date

Cells.Find(What:="Project End Date", After:=ActiveCell, LookIn:= _
        xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False).Activate
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveCell.Offset(0, 1).Activate
    Selection.ClearContents
    ActiveCell.Offset(1, 0).Activate
    Selection.ClearContents
    ActiveCell.Offset(0, -1).Activate
    Selection.ClearContents

'Moves % spend
Range("D7:D8").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("E7:E8").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("D7").Select
    Selection.FillDown
    Range("E7").Select
    Selection.FillDown
    
'adds budget spend %

Range("D6").Select
ActiveCell = "% Budget Spent"
Range("E14").Select
SpentPCent = ActiveCell
Range("E6").Select
Selection.NumberFormat = "0.00"
ActiveCell = SpentPCent
Range("D7").Select
ActiveCell = "% Time Elapsed"
Range("E9").Select
TimeElap = ActiveCell
Range("E7").Select
Selection.NumberFormat = "0.00"
ActiveCell = TimeElap
Range("D9").Select
Selection.ClearContents
ActiveCell.Offset(0, 1).Activate
Selection.ClearContents
Range("D8").Select
ActiveCell = "Top Task Number"
Range("B12").Select
TopTask = ActiveCell
Range("E8").Select
ActiveCell = TopTask
    
'deletes task info box
Rows("10:16").Select
Selection.Delete Shift:=xlUp
Range("A10").Select

'''msgbox ""


Dim ProNum As String

Cells.Find(What:="Project Number", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 1).Select
ProNum = ActiveCell
''''msgbox ProNum

'Roles up EC non Staff budgets and spend

 '   Cells.Find(What:="funder", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
  '      :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
   '     False, SearchFormat:=False).Activate

'ActiveCell.Offset(0, 1).Activate
'If ActiveCell = "European Commission" Then

 '   Cells.Find(What:="Expenditure Category", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
  '      :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
   '     False, SearchFormat:=False).Activate
        
'Do Until ActiveCell = "Top Task Total"
'ActiveCell.Offset(1, 0).Activate
'If ActiveCell <> "Other Direct Costs" Then '''msgbox "what next?"


'Loop
'End If


'deletes rows where budget and actuals are zero

Cells.Find(What:="Funds Available", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select
''''msgbox ActiveCell

''''msgbox "stop"

Dim RemoveCell1
Dim RemoveCell2


Do Until ActiveCell.Offset(0, -4) = ""
RemoveCell1 = ActiveCell.Offset(0, -4)
RemoveCell2 = ActiveCell.Offset(0, -3)
If RemoveCell1 + RemoveCell2 = "0" Then Selection.EntireRow.Delete: ActiveCell.Offset(-1, 0).Select
ActiveCell.Offset(1, 0).Select
Loop

'adds subtotal
''''msgbox ""

Dim EndCell As String
Dim StartCell As String

Range("A1").Select
Cells.Find(What:="Task Cost Summary Report", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
''''msgbox ""
ActiveCell.Offset(1, 0).Activate
StartCell = ActiveCell.Row()


    Cells.Find(What:="Funds Available", After:=ActiveCell, LookIn:=xlFormulas _
        , LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    Selection.End(xlDown).Select
''''msgbox ""

EndCell = ActiveCell.Row()
''''msgbox ""

Range("B" & StartCell & ":H" & EndCell - 1).Select
    
        Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
        7), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    
''''msgbox ""
    
Range("A1").Select
Cells.Find(What:="Grand Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Rows(ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
'''msgbox ""

'WAS HERE
'makes subtotal bold
''msgbox "sub bold"
Range("A1").Select
Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
''''msgbox ""
EndCell = ActiveCell.Row()
''msgbox StartCell
With Range("B" & StartCell & ":H" & EndCell + 1)
''msgbox EndCell
    Set C = .Find(What:="subtotal", LookIn:=xlFormulas)
    If Not C Is Nothing Then
       firstAddress = C.Address
       Do
            C.EntireRow.Font.Bold = True
            Set C = .FindNext(C)
        Loop While Not C Is Nothing And C.Address <> firstAddress
    End If
    
End With
''''msgbox ""
'adds %spent

Range("A1").Select
Cells.Find(What:="Funds Available", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

ActiveCell.Offset(0, 1).Select
ActiveCell.Value = "% Spent"
ActiveCell.Offset(0, -1).Select
Selection.Copy
ActiveCell.Offset(0, 1).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

Range("A1").Select
'Cells.Find(What:="All Total", After:=ActiveCell, LookIn:=xlFormulas, _
'LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
'MatchCase:=False, SearchFormat:=False).Activate

'ActiveCell.Offset(0, 6).Select
'Selection.Copy
'ActiveCell.Offset(0, 1).Select
'Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
 '       SkipBlanks:=False, Transpose:=False

    Columns("I:I").Select
    Selection.NumberFormat = "0.00%"
    Selection.NumberFormat = "0%"
    


Range("A1").Select
Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select

Do Until ActiveCell.Offset(0, -5) = ""
''''msgbox "Pause"


Dim Bnumber As Integer
Bnumber = 1
On Error Resume Next
''''msgbox Err.Number
If ActiveCell.Offset(0, -7) <> " " Or ActiveCell.Offset(0, -4) <> "0" Or ActiveCell.Offset(0, -5) <> "0" Then

'If Err.Number > 0 Then
''''msgbox Err.Number
On Error Resume Next
If ActiveCell.Offset(0, -5) = 0 Then
ActiveCell = ActiveCell.Offset(0, -2) / Bnumber
Else:
ActiveCell = ActiveCell.Offset(0, -2) / ActiveCell.Offset(0, -5)
End If


End If
On Error GoTo 0


ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
Selection.Font.Bold = True

'inserts message about no budget
''''msgbox "stop"
Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select

Do Until ActiveCell.Offset(0, -5) = ""
If ActiveCell.Value = "" Then ActiveCell.Value = "No Budget"
ActiveCell.Offset(1, 0).Select
Loop

Columns("I:I").EntireColumn.AutoFit

Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Select
ActiveCell = "Balance Remaining"


Columns("H:H").EntireColumn.AutoFit


'hides RC savings lines and leaves total

'Dim RCHide As String
'Dim RCunhide As String

'RCHide = "RC RCUK Efficiency Savings"
'RCunhide = "RC RCUK Efficiency Savings Total"

Range("B1").Select


    Cells.Find(What:="Task Name", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
         
 
ActiveCell.Offset(1, 0).Select
 
Do Until ActiveCell.Value = "Top Task Total"

    If ActiveCell.Value = "RCUK" Then Selection.EntireRow.Hidden = True
    'If ActiveCell.Value = RCunhide Then Selection.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select

Loop
''''msgbox "stop"

'deletes summary
ActiveCell.Offset(1, 0).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete





 Range("I12").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Columns("I:I").EntireColumn.AutoFit
    Columns("F:F").EntireColumn.AutoFit
    Columns("G:G").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit

Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

  With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("I11").Select
    Range(Selection, Selection.End(xlToLeft)).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge

Range("A11:I11").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With

'  Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
'    Application.PrintCommunication = True

Range("A1").Select

''''msgbox "Tidy"


    Rows("3:3").Select
    Selection.UnMerge
    Range("C4:C9").Select
    Selection.UnMerge
Rows("9:12").Select

''''msgbox ""


    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    
    
    Range("D4:E9").Select
    Selection.Copy
    Range("A9").Select
    ActiveSheet.Paste
 '   Rows("9:9").Select
  '  Application.CutCopyMode = False
   ' Selection.Delete Shift:=xlUp
    'Rows("14:14").Select
    'Selection.Delete Shift:=xlUp
    Rows("3:3").Select
    Selection.UnMerge
    Range("C3:E14").Select
    

    
    Selection.ClearContents
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A3:B13").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A1").Select


 '   Selection.Delete Shift:=xlUp
    Range("B4:B13").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    Dim SpendPercent As String
    Dim TimePercent As String
    
    Range("B11").Select
    ActiveCell.Value = Round(ActiveCell.Value, 0)
    Range("B12").Select
    ActiveCell.Value = Round(ActiveCell.Value, 0)
       
 
    
   

 Range("B11:B12").Select
      
    Selection.NumberFormat = "0"
    
    Range("B11").Select
    SpendPercent = ActiveCell
    
    ''''msgbox SpendPercent
    Selection.NumberFormat = "@"
    ActiveCell = SpendPercent & "%"

    Range("B12").Select
    TimePercent = ActiveCell
    
 '   '''msgbox SpendPercent
    Selection.NumberFormat = "@"
    ActiveCell = TimePercent & "%"
    
    
    
    
    
    'Round.ActiveCell
    
    
     Range("A14:B14").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A3:B13").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("A15:I15").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    
    Range("A15:I15").Select
    Selection.UnMerge
    Columns("D:H").Select
    Selection.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
    Range("A15:I15").Select
    Selection.Merge
    
    
    Range("A1").Select

'adds formulas to report

    Cells.Find(What:="Total Cost", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
      
        ActiveCell.Offset(1, 0).Activate
        
        Do Until ActiveCell = ""
        If Selection.Font.Bold = False Then
        ActiveCell.FormulaR1C1 = "=RC[-2]+RC[-1]"
        ActiveCell.Offset(1, 0).Activate
        Else: ActiveCell.Offset(1, 0).Activate
        End If
        Loop
    
    
    
    Cells.Find(What:="Balance Remaining", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
        ActiveCell.Offset(1, 0).Activate
        
        
        Do Until ActiveCell = ""
        If Selection.Font.Bold = False Then
        ActiveCell.FormulaR1C1 = "=RC[-4]-RC[-1]"
        ActiveCell.Offset(1, 0).Activate
        Else: ActiveCell.Offset(1, 0).Activate
        End If
        Loop
        
    
    Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        
        ActiveCell.Offset(1, 0).Activate
        
        
        
        Do Until ActiveCell = ""
        If ActiveCell.Value = "No Budget" Then
        ActiveCell.Offset(1, 0).Activate
        Else: ActiveCell.FormulaR1C1 = "=RC[-2]/RC[-5]"
        ActiveCell.Offset(1, 0).Activate
        End If
        Loop
        
'inserts message about no budget
''''msgbox "stop"


Dim cel As Range
Cells.Find(What:="% Spent", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(1, 0).Select

Do Until ActiveCell.Offset(0, -5) = ""

If ActiveCell.Offset(0, -5) = "0" Then ActiveCell = "No Budget"

ActiveCell.Offset(1, 0).Select
Loop


        
'subtotals bottom line

 Cells.Find(What:="Total Budget", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Dim Start As String
Dim Finish As String
Dim LineNos As String

Start = ActiveCell.Row()
''''msgbox Finish - Start

    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()
'''msgbox Finish

LineNos = Finish - Start + 1

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"

''''msgbox ""

 Cells.Find(What:="Actuals", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Start = ActiveCell.Row()
''''msgbox Start
    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"

Range("A1").Select
 Cells.Find(What:="Commitments", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Start = ActiveCell.Row()
''''msgbox Start
    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"

 Cells.Find(What:="Total Cost", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Start = ActiveCell.Row()
''''msgbox Start
    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"

Cells.Find(What:="Balance Remaining", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
    
        ActiveCell.Offset(1, 0).Activate

Start = ActiveCell.Row()
''''msgbox Start
    
Selection.End(xlDown).Select

ActiveCell.Offset(-1, 0).Activate
Finish = ActiveCell.Row()

Selection.End(xlDown).Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-" & LineNos & "]C:R[-1]C)"


ActiveWindow.View = xlNormalView



Range("A1").Select
ActiveCell = Title
ActiveCell.Font.Bold = True
Cells.Select
Selection.RowHeight = 15

Range("A1").Select


    Cells.Find(What:="Task Name", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
         
 
ActiveCell.Offset(1, 0).Select
 
Do Until ActiveCell.Offset(0, -1).Value = "Top Task Total"

    If ActiveCell.Value = "RCUK" Then Selection.EntireRow.Hidden = True
    'If ActiveCell.Value = RCunhide Then Selection.EntireRow.Hidden = False
ActiveCell.Offset(1, 0).Select

Loop

'Columns("I:I").EntireColumn.AutoFit

'HERE
'Columns("B:I").EntireColumn.AutoFit


ActiveSheet.Name = ProNum

 Rows("13:13").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A13").Select
    ActiveCell.FormulaR1C1 = "Actuals As At"
    ActiveCell.Offset(0, 1).Value = DTPicker1
        
        Range("B13").Select
    Selection.ClearContents
    Selection.NumberFormat = "dd-mmm-yy"
    ActiveCell.FormulaR1C1 = "=TODAY()"
    Range("A1").Select

        
  'adds Notes relating to end date
     Cells.Find(What:="announced end", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, 1).Select
ActiveCell.Name = "ABC"
     Cells.Find(What:="actuals as at", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate
        ActiveCell.Offset(0, 1).Select
     ActiveCell.Name = "DEF"
     Range("ABC").Select
     
     'less than 6 months
         If (Range("ABC") - Range("DEF") < 183 And (Range("ABC") - Range("DEF") >= 91)) Then
                        ActiveCell.Interior.ColorIndex = 6 ' Color cell interior yellow
                        ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project is due to end within the next 6 months."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
                         
                         
        'less than 3 months
                        
         ElseIf (Range("ABC") - Range("DEF") <= 90 And (Range("ABC") - Range("DEF") >= 61)) Then
                         ActiveCell.Interior.ColorIndex = 44 'Color cell darker yellow/gold
                         ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project is due to end within the next 3 months."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
                        
       'Less than 2 months
       ElseIf (Range("ABC") - Range("DEF") <= 60 And (Range("ABC") - Range("DEF") >= 31)) Then
                         ActiveCell.Interior.ColorIndex = 45 'Cell color even darker yellow/light orange
                         
                        ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project is due to end within the next 2 months."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
                        
                            
     'Less than one month
     ElseIf (Range("ABC") - Range("DEF") <= 30 And (Range("ABC") - Range("DEF") >= 1)) Then
                         ActiveCell.Interior.ColorIndex = 46 'Cell color darkest orange
                        
                        ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project is due to end within the next month."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
                        
     'finished
    ElseIf Range("ABC") - Range("DEF") <= 0 Then
    ActiveCell.Interior.ColorIndex = 3  ' Color cell darkest red
    
     ActiveCell.Offset(-3, 2).Activate
                        ActiveCell.Value = "This project has now finished."
                                          
                        ActiveCell.Name = "GHI"
                        ActiveCell.Offset(-1, 0).Activate
                        ActiveCell.Value = "Note:"
                        ActiveCell.Name = "JKL"
                        
                        Union(Range("GHI"), Range("JKL")).Select
                        With Selection
                            .WrapText = False
                            .Font.Italic = True
                            .Font.Bold = True
                        End With
    
    
    
    Else
            ActiveCell.Select
  End If
  


Range("A1").Select



ActiveSheet.Name = ProNum







Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
'deletes summary
ActiveCell.Offset(1, 0).Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).EntireRow.Delete


Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(2, 0).Select
ActiveCell = "1. Salary commitments, as held on the HR or Payroll systems, are not included in this report."



Dim RowLocation As Long          'can hold over 32000 if over this many rows
Dim ColumnLocation As Integer   'columns won't exceed 256 in sheet
Dim CellLocation As String



Range("B1").Select
Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, 7).Select

CellLocation = ActiveCell.Address

''msgbox CellLocation


Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(3, 0).Select
ActiveCell = "Please bear this in mind when reviewing the remaining balance total of:"
 
Dim CurrentCell As String


CurrentCell = ActiveCell.Row()
Range("A" & CurrentCell & ":D" & CurrentCell).Merge
ActiveCell.Offset(0, 1).Activate
ActiveCell.Value = "=" & CellLocation
Selection.NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"

 

''msgbox "OK?"


Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(4, 0).Select
ActiveCell  = "2. Commitments - Costs that have been charged to the award, but are  not yet actual e.g. a PO that has yet to be matched to an invoice."

Cells.Find(What:="Top Task Total", After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
ActiveCell.Offset(5, 0).Select
ActiveCell = "3. %Time Elapsed = Number of days since the start date of the award as a percentage of the duration of the award."


'msgbox "stop"

    Columns("C:C").Select
    Selection.ColumnWidth = 20
    
    Columns("E:E").Select
    Selection.ColumnWidth = 12
    
Next ws

'Application.ScreenUpdating = True

  
   ' ActiveWindow.Close
'End If
End Sub

My progress bar is currently in a userform called Userform2 is that right?
There is nothing in the Private Sub UserForm_activate() at the moment.

So do I need a Userform2.Show at the start of the above long code to show the progress bar and then put that subloop120 code in the Userform_Activate VBA? Is it possible to run 2x subs at the same time?
Or does the entire code need to go through the Progress Bar-Userform2 Say a 'Call Main' and me rename the Private Sub CommandButton1_Click() as Sub Main?

Everytime I try and integrate code to run the progress bar I am getting errors that sub not defined.

Sorry I am quite new to this.
 
Upvote 0
No, the Loop100 code was meant as an example to show the UpdateProgressBar being called 100 times from another macro, i.e. the width being updated from 0 to 100%. By re-writing to 120, you are now updating the progress bar to 120% of its original size

In your case, you want the UpdateProgressBar line of code to be added at key points of your macro, not the whole loop100 / loop120 code

Looking at your Userform:
- Looking at the Project Explorer in the top left of the VB Editor, you can see your user form. I take it that it is named UserForm2 here? If so then yes, that is its name. You can change this if you want, from the Properties window which should ideally be located below the Project Explorer.
- your form may or may not have "events" associated with it. These are specific bits of code designed to run when certain things occur, e.g. the userform opens, a button is clicked etc. You only use these because there is a specific trigger that you want to happen. Do you want code to run when you open your form for the first time? In the case of a progress bar you probably don't - you'd use it for filling combo boxes for example

In this case, you want it to run as follows:
- Near start of your code, you want to load the form for first time and set width / caption to 0%. You don't need anything to run automatically.
- During your code you want to calculate your progress as a percentage i and then have UpdateProgressBar i change the width / caption.
- At the end of the code you want the progress bar to disappear

I'm gonna digress for a bit. To do things in VBA you need to define an object and then perform an action on it or query/change its properties. The most common mistake made stems from recording macros, which record everything you do, in particular selecting new cells. For example
Code: 
Range("D6").Select
ActiveCell = "% Budget Spent"
relates to the object Range("R6"); first you are performing the action .Select in order to create a Selection/Activecell object. Then you are changing the .Value property of the Selection object to "% Budget Spent". You could do all of this without Select, by writing simply
Code: 
Range("D6") = "% Budget Spent"
This alone will greatly simplify your current code and should be the first thing you do - once you get a better grasp of the objects you're working with and what you're doing to them, you'll better understand where you're falling over

On a similar note, you can probably remove 95% of the code that relates to changing cell formats, which is basically slowing your code down and making it really difficult to see what's important. Refer to each range properly, and change the setting you need to change, so
Code: 
Range("D7:D8").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("E7:E8").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Selection.UnMerge
    Range("D7").Select
    Selection.FillDown
    Range("E7").Select
    Selection.FillDown
will probably become something like
Code: 
Range("D7:D8").Unmerge
Range("D7").Filldown
Range("E7").Filldown

You mentioned that you estimate you'll hit "next ws" about 120 times. I assume you have approx 120 worksheets then, and want to increment your statusbar each time you hit next ws. In which case we want to call UpdateProgressBar 120 times, but each time incrementing by (100/120)% - meaning we'll reach 100% on the 120th iteration

You'll need:
Code: 
dim i as counter
somewhere near the top of your code
Code: 
i = i + 1
during each iteration i.e. after for each ws...
Code: 
UpdateProgressBar i/activeworkbook.worksheets.count
before next ws
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question Question
Macros and protecting a cell
Replies
5
Views
187
Fluff
Fluff
R
  • Question Question
cells.find error handling
2
Replies
13
Views
742
jolivanes
jolivanes
R
  • Question Question
Find value and delete all rows below it
Replies
7
Views
134
MikeVol
MikeVol
F
  • Solved
Looping code sequence
Replies
5
Views
483
FrenchCelt
F
S
  • Solved
Search for entered value in another tab
Replies
3
Views
174
skittlz
S

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top