Faking an animated image in a userform?

BBrandt · Jul 22, 2008

I've gathered that it's not possible to place an animated GIF like this:

in a userform in Excel. As you might have guessed, I've created a macro that, depending on user inputs, can take a bit of time to run, and I want to display something to let the user know that Excel hasn't locked up. Ideally, this would be a sort of faux status bar like the one above that implies that there is work being done without necessarily actually indicating the amount of work completed (I figure that would be easier to code).

Do you have any recommendations about how to accomplish something like this? Ideally also I'd like to not have to download anything in order to make this work, as the spreadsheet is designed for others to use, so it would be inconvenient if they had to install an add-in or similar to get it to run. Thanks in advance!

BBrandt · Jul 23, 2008

Thanks everyone, I should be able to use one of those I think. Which one I end up using will probably be whichever one I can code in faster, but thanks for all the help, I hadn't run across a few of those examples before.

MickG · Jul 23, 2008

Hi,BBrant
Just for interest I've added a large dot to the Status Bar code "chr(149)".
This code gives you a progressbar of sorts, which you can mod for your code.
Dots seem limited to about 80, but if you adjust the MOD operator in the code you can cope with any number of loops.

Code:

Dim d, a, dot, c
Application.StatusBar = ""
For d = 1 To 40000
    If d Mod 500 = 0 Then
        dot = dot & Chr(149)
        c = c + 1
    End If
    Application.StatusBar = "Portion completed:  " & dot
Next d
MsgBox "Number in loop =" & d & "/" & "Number of dots =" & c
Application.StatusBar = ""
[/code
Regards Mick

Legacy 98055 · Jul 23, 2008

<a href="http://home.fuse.net/tstom/0723081402.331735.zip"><img src="http://home.fuse.net/tstom/zip.gif"width="48"height="48"border="0"></a> <a href="http://home.fuse.net/tstom/0723081402.331735.zip">0723081402.331735.zip</a>

This example will display your animated gif using a webbrowser control. Some improvements I would make...

Remove the titlebar of the userform. Easy.
Add the ability to change the backcolor. Easy.
Dynamically adjust the size of the gif. A bit less than easy.

Add userform with Width:=308.25, Height:=63.75
Add WebBrowser1 at Left:=(-6), Top:=0, Width:=310, Height:=42
Add this code:

HTML:

Private Sub UserForm_Initialize()
    Me.BackColor = RGB(235, 233, 237)
    With WebBrowser1
        .Navigate "about:<STYLE>BODY{border-style:none;}</STYLE><html><body bgcolor=""rgb(235, 233, 237)""><img src=""http://img148.imageshack.us/img148/5016/progressbarpf7.gif"" width=""400"" height=""30"" /></body></html>"
        Do Until .Document.ReadyState = "complete" And Not .Busy And .ReadyState = READYSTATE_COMPLETE: DoEvents: Loop
        .Document.body.Scroll = "no"
    End With
End Sub

BBrandt · Jul 23, 2008

Very nice.

The only trouble with that is that I'm hesitant to reference a website where I have no control over things like downtime or whether the user is even connected to the internet. I realize that I could just use the web address area to reference the .gif on my computer or a network drive, but since this'll be used by several people on different machines, I'd rather not require the user to have files other than the excel sheet. I'd hate to have the macro stop mid-stream on someone if it couldn't locate the .gif for whatever reason.

That said, I have to say that's about as close to what I wanted originally as anyone's gotten, even though in the end I'm probably going to go with a progress indicator that actually indicates progress. Thanks again!

Legacy 98055 · Jul 23, 2008

Do you have access to the progressbar control? Is in MSCOMCTL.OCX. Check additional controls from the userform toolbox...
I like the 'Control the LED Display in the StatusBar' . Very nice.

BBrandt · Jul 24, 2008

Big thanks to everyone on this thread. I ended up going with the Control LED Display in the StatusBar that VoG II posted. Works like a charm! I keep running my macro so I have an excuse to watch it

.

Thanks again, I look forward to the day that when I know enough about excel and VBA to contribute help rather than just questions to this board!

fpskidmark · Sep 20, 2011

Hi Andrew,

I was able to create the userform for my lengthy macro, but where do I enter my code? I added my code at the end of the code below, but the code times out and I get an error msg "Out of Stack Space".
Any suggestions?

Thank you,
FP

PHP:

 Sub Main()

   'Inserts random numbers on the active worksheet
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim rz As Integer, c As Integer
    Dim PctDone As Single
    
    Sheets("Random").Visible = True
    Sheets("Random").Select
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    Cells.Clear
    Application.ScreenUpdating = False
    Counter = 1
    RowMax = 100
    ColMax = 25
    For rz = 1 To RowMax
        For c = 1 To ColMax
            Cells(rz, c) = Int(Rnd * 1000)
            Counter = Counter + 1
        Next c
        PctDone = Counter / (RowMax * ColMax)
        With UserForm1
            .FrameProgress.Caption = Format(PctDone, "0%")
            .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
       End With
'       The DoEvents statement is responsible for the form updating
        DoEvents
   Next rz
 Unload UserForm1
'   The UserForm1_Activate sub calls Main
    UserForm1.LabelProgress.Width = 0
    UserForm1.Show

Andrew Poulsom said:
Maybe you can adapt this:

http://www.j-walk.com/ss/excel/tips/tip34.htm

Andrew Poulsom · Sep 20, 2011

What's your current code and how did you try to incorporate the code in the link I posted?

fpskidmark · Sep 20, 2011

My code is massive (see below). I added the code at the end of your code

PHP:

 'WAIVES TAB
    N = Workbooks("Monthly Sox Report Macro.xls").Sheets("Macro").Range("i2").Value
    Workbooks.Open Filename:="P:\\Microsoft Excel\Projects\Monthly SOX Report\G-BP Monthly POS Review.xls"
    Sheets("Waives").Select
    
    Cells.Select
    With Selection.Font
        .Name = "Arial"
        .Size = 8
        .ColorIndex = 0
        .Bold = False
    End With
    Rows("1:1").Font.ColorIndex = 11: Rows("1:1").Font.Bold = True
    
    LASTROW = Range("A65536").End(xlUp).Row
    Range(Cells(2, "a"), Cells(LASTROW, "N")).Delete
    
    Rows("1:1").AutoFilter
    Columns("B:B").Insert Shift:=xlToRight
    Range("K:K,M:M").Delete Shift:=xlToLeft
    Workbooks.Open Filename:="P:\\Microsoft Excel\Projects\Monthly SOX Report\Raymond\Baldwin Park Pos Collection.xls"
    Sheets("WaivesYTD").Select
    
    Range("B6:N65000").AutoFilter Field:=2, Criteria1:=N
    Range("B7:N65000").Copy
    Windows("G-BP Monthly POS Review.xls").Activate
    Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Columns("A:A").NumberFormat = "m/d/yyyy;@"
 
    Windows("G-BP Monthly POS Review.xls").Activate
    Columns("B:B").Delete Shift:=xlToLeft
    Columns("J:J").Insert Shift:=xlToRight
    Columns("L:L").Insert Shift:=xlToRight
    Range("L1").FormulaR1C1 = "CCNT"
    Range("L1").Font.ColorIndex = 11
    Range("M28:M29").Select
    Range("J1").FormulaR1C1 = "LOC"
    Range("J1").Font.ColorIndex = 11
  
    Columns("N:N").Select
    Selection.NumberFormat = "$#,##0.00"
    Columns("N:N").HorizontalAlignment = xlRight
    Columns("B:B").NumberFormat = "0"
    LASTROW = Range("a" & Rows.Count).End(xlUp).Row
    For i = LASTROW To 2 Step -1
    Cells(i, "b").FormulaR1C1 = (Cells(i, "b") * 1)
    If Cells(i, "i") = "BALDWIN PARK MEDICAL OFFICES U" Then Cells(i, "j").FormulaR1C1 = "552"
    If Cells(i, "i") = "CROSSROADS MEDICAL OFFICES U" Then Cells(i, "j").FormulaR1C1 = "563"
    If Cells(i, "i") = "DIAMOND BAR MEDICAL OFFICES U" Then Cells(i, "j").FormulaR1C1 = "554"
    If Cells(i, "i") = "MONTEBELLO MEDICAL OFFICES U" Then Cells(i, "j").FormulaR1C1 = "558"
    If Cells(i, "i") = "SAN DIMAS MEDICAL OFFICES U" Then Cells(i, "j").FormulaR1C1 = "553"
    If Cells(i, "i") = "W COVINA PKWY BEHAVIORAL HEALTH U" Or Cells(i, "i") = "WEST COVINA BEHAVIORAL HEALTH U" Then Cells(i, "j").FormulaR1C1 = "556"
    If Cells(i, "i") = "WEST COVINA MEDICAL OFFICES U" Then Cells(i, "j").FormulaR1C1 = "557"
    Next i
    Cells.Sort Key1:=Range("I2"), Order1:=xlAscending, Key2:=Range("H2") _
        , Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
        , Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
        xlSortNormal
        
Range("A1").Select
'Application.DisplayAlerts = False
'Workbooks("Baldwin Park Pos Collection.xls").Close
    Windows("G-BP Monthly POS Review.xls").Activate
    Columns("A:N").Subtotal GroupBy:=9, Function:=xlSum, TotalList:=Array(14), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    Selection.Subtotal GroupBy:=8, Function:=xlCount, TotalList:=Array(11), _
        Replace:=False, PageBreaks:=False, SummaryBelowData:=True
    Cells.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("A:N").RemoveSubtotal
Sheets("Waives").Select
   LASTROW = Range("a" & Rows.Count).End(xlUp).Row
    For k = 2 To LASTROW
    If Cells(k, "h") Like "*Count" Then Cells(k, "a") = Cells(k, "h"): Cells(k, "h").ClearContents
    If Cells(k, "i") Like "*Total" Then Cells(k, "a") = Cells(k, "i"): Cells(k, "i").ClearContents
    If Cells(k, "a") Like "*Count" Then Range("A" & k & ".N" & k).Font.ColorIndex = 5: Range("A" & k & ".N" & k).Font.Bold = True
    If Cells(k, "a") Like "*Total" Then Range("A" & k & ".N" & k).Font.ColorIndex = 1: Range("A" & k & ".N" & k).Font.Bold = True: Range("A" & k & ".N" & k).Font.Size = 10
Next k
Cells.Cells.EntireColumn.AutoFit
Columns("G:G").ColumnWidth = 25
Columns("A:A").ColumnWidth = 30

 Windows("Monthly Sox Report Macro.xls").Activate
 Sheets("Macro").Range("G2").Copy
 Windows("G-BP Monthly POS Review.xls").Activate
 Sheets("Monthly Dashboard").Range("C3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
' ************************************************************************************************************
'                  PART II - SMALL SPREADSHEET: G- Coll by Loc-Dept-User.xls
' ************************************************************************************************************
'
    Workbooks.Open Filename:="P:\\Microsoft Excel\Projects\Monthly SOX Report\G- Coll by Loc-Dept-User.xls"
    Sheets("Current Month").Visible = True
    Sheets("Current Month").Select
    LASTROW = Range("b65536").End(xlUp).Row
    Range(Cells(2, "b"), Cells(LASTROW, "Q")).Delete
    
    Windows("Baldwin Park Pos Collection.xls").Activate
    Sheets("DataMTD").Select
    LASTROW = Range("b65536").End(xlUp).Row
    Range(Cells(5, "b"), Cells(LASTROW, "Q")).Copy
    
    Windows("G- Coll by Loc-Dept-User.xls").Activate
    Sheets("Current Month").Range("B2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Collections by Facility").PivotTables("PivotTable1").PivotCache.Refresh
    Sheets("Collections by Dept").PivotTables("PivotTable1").PivotCache.Refresh
    Sheets("Collections by Receptionist").PivotTables("PivotTable1").PivotCache.Refresh
    
    Sheets("Collections by Facility").Select
    LASTROW = Range("a" & Rows.Count).End(xlUp).Row
    For z = 4 To LASTROW - 1
    Cells(z, "f").Font.Bold = False: Cells(z, "f").Font.ColorIndex = 1: Cells(z, "f").Interior.ColorIndex = 2
    If Cells(z, "f") < "0.965" Then Cells(z, "f").Font.Bold = True: Cells(z, "f").Font.ColorIndex = 3: Cells(z, "f").Interior.ColorIndex = 19
    Next z
 
    Sheets("Collections by Dept").Select
    LASTROW = Range("a" & Rows.Count).End(xlUp).Row
    For z2 = 4 To LASTROW - 1
    If Cells(z2, "b") <> "" Then Cells(z2, "g").Font.Bold = False: Cells(z2, "g").Font.ColorIndex = 1: Cells(z2, "g").Interior.ColorIndex = 2
    If Cells(z2, "b") <> "" And Cells(z2, "g") <> "0" And Cells(z2, "g") < "0.965" Then Cells(z2, "g").Font.Bold = True: Cells(z2, "g").Font.ColorIndex = 3: Cells(z2, "g").Interior.ColorIndex = 19
    Next z2
    
    Sheets("Collections by Receptionist").Select
    LASTROW = Range("a" & Rows.Count).End(xlUp).Row
    For z3 = 6 To LASTROW - 1
    Cells(z3, "f").Font.Bold = False: Cells(z3, "f").Font.ColorIndex = 1: Cells(z3, "f").Interior.ColorIndex = 2
    If Cells(z3, "f") <> "0" And Cells(z3, "f") < "0.965" Then Cells(z3, "f").Font.Bold = True: Cells(z3, "f").Font.ColorIndex = 3: Cells(z3, "f").Interior.ColorIndex = 19
    Next z3
    Sheets("Current Month").Visible = False
    Sheets("Collections by Facility").Select
    
' ************************************************************************************************************
'                  PART III - TAB "POS Collection"
' ************************************************************************************************************
'
    
    Workbooks.Open Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Raymond\SCAL MOB POS Collection.xls"
    
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("POS Collections").Select
    LASTROW = Range("A65536").End(xlUp).Row
    Range(Cells(2, "a"), Cells(LASTROW, "p")).Delete
        Cells.Select
    With Selection.Font
        .Name = "Arial"
        .Size = 8
        .ColorIndex = 0
        .Bold = False
    End With
    Columns("L:L").Delete
    Columns("A:A").Insert Shift:=xlToRight
    Rows("1:1").Font.ColorIndex = 11: Rows("1:1").Font.Bold = True
    
    Windows("SCAL MOB POS Collection.xls").Activate
    Sheets("RegByDept").Select
    Sheets("RegByDept").PivotTables("PivotTable2").PivotCache.Refresh
    Sheets("RegByDept").PivotTables("PivotTable2").PivotFields("YYYYMM").CurrentPage = N
    Sheets("RegByDept").PivotTables("PivotTable2").PivotFields("MCA").CurrentPage = "Baldwin Park"
    Sheets("RegByType").PivotTables("PivotTable1").PivotFields("YYYYMM").CurrentPage = N
    Sheets("Trend").Select
    Sheets("Trend").PivotTables("TrendForTable").PivotCache.Refresh
    Sheets("Trend").PivotTables("TrendForTable").PivotFields("MCA").CurrentPage = "Baldwin Park"
       
    Sheets("RegByDept").Select
    LASTROW = Range("h65536").End(xlUp).Row
    Range(Cells(11, "b"), Cells(LASTROW, "p")).Copy
    
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("POS Collections").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("POS Collections").Select
    Columns("M:M").Insert Shift:=xlToRight
    Range("M1").FormulaR1C1 = "$ % Billed": Range("M1").Font.ColorIndex = 11
    
    Sheets("POS Collections").Select
    LASTROW = Range("c" & Rows.Count).End(xlUp).Row
    For q = 2 To LASTROW
    If Cells(q, "a") Like "*Total" Then Cells(q, "b") = Cells(q, "a")
    Next q
    
    Columns("A:A").Delete
    
    Sheets("POS Collections").Select
    LASTROW = Range("b" & Rows.Count).End(xlUp).Row
    For q2 = 2 To LASTROW
    Cells(q2, "l").FormulaR1C1 = "=IF(RC[-3]=0,0,RC[-1]/RC[-3])"
    Next q2
    
    Columns("L:L").Copy
    Columns("L:L").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Range("B:B,C:C,D:D,E:E,F:F,H:H,I:I,K:K,M:M").NumberFormat = "#,##0"
    Range("G:G,J:J,L:L,N:N,O:O").NumberFormat = "0.00%"
    
    Columns("B:O").ColumnWidth = 9.57
    
    Sheets("POS Collections").Select
    LASTROW = Range("a" & Rows.Count).End(xlUp).Row
    For q3 = 2 To LASTROW
    If Cells(q3, "j") <> "0" And Cells(q3, "j") < "0.965" Then Cells(q3, "j").Font.Bold = True: Cells(q3, "j").Font.ColorIndex = 3: Cells(q3, "j").Interior.ColorIndex = 19
    If Cells(q3, "a") Like "*Total" Then Range("A" & q3 & ".O" & q3).Font.Bold = True: Range("A" & q3 & ".O" & q3). _
    Font.Size = 10: Range("A" & q3 & ".O" & q3).Interior.ColorIndex = 16: Range("A" & q3 & ".O" & q3).Font.ColorIndex = 1
    If Cells(q3, "a") = "Grand Total" Then Range("A" & q3 & ".O" & q3).Interior.ColorIndex = 1: Range("A" & q3 & ".O" & q3).Font.ColorIndex = 2
    Next q3
    
' ************************************************************************************************************
'                  PART IV - - TAB "HB Sum"
' ************************************************************************************************************
    Workbooks.Open Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Raymond\SCAL Hospital Copay.xls"
    Sheets("Sheet1").Rows("11:65000").Copy
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("HB Sum").Select
    Rows("11:11").Select
    ActiveSheet.Paste: Application.CutCopyMode = False
    With Selection.Font
        .Name = "ARIAL"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
    End With
    Selection.Font.ColorIndex = 0
    Windows("SCAL Hospital Copay.xls").Activate
    Rows("3:4").Copy
    Windows("G-BP Monthly POS Review.xls").Activate
    Rows("3:3").Select
    ActiveSheet.Paste: Application.CutCopyMode = False
 
 Columns("AC:AC").ColumnWidth = 10: Columns("AH:AH").ColumnWidth = 10:  Columns("AJ:AJ").ColumnWidth = 10: _
 Columns("AM:AM").ColumnWidth = 10: Columns("G:G").ColumnWidth = 9
 
   LASTROW = Range("B" & Rows.Count).End(xlUp).Row
    For U = 10 To LASTROW
    If Cells(U, "Y") <> "" Then Cells(U, "Y").Font.ColorIndex = 3
    Next U
    Rows("58:65000").Delete
    
    
' ************************************************************************************************************
'                  PART V - TAB "HB COL"
' ************************************************************************************************************
    Workbooks.Open Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\WIKI\WIKI Copay Report.xls"
    Cells.Copy
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("WIKI").Visible = True
    Sheets("WIKI").Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("HB Col").PivotTables("Felix").PivotCache.Refresh
    Sheets("HB Col").Select
    Columns("B:G").WrapText = True: Columns("B:G").ColumnWidth = 15
    Rows("3:3").EntireRow.AutoFit
    Sheets("WIKI").Visible = False
    
    
' *************************************************************************************************************
'                  PART VI - TAB "VOIDS"
' *************************************************************************************************************
    
    Workbooks.Open Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Card Website\Void From Card.xls"
    Sheets("Sheet1").Select
    Cells.Copy
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("Void Data").Visible = True
    Sheets("Void Data").Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Voids").PivotTables("Felix2").PivotCache.Refresh
    Sheets("Voids").Select
    Columns("C:C").HorizontalAlignment = xlRight
    Sheets("Void Data").Visible = False
' *************************************************************************************************************
'                  PART VII - TAB "CASH DRAWER"
' *************************************************************************************************************
    
    
   Workbooks.Open Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Brigida\Cadence cash drawer Response by MSA.xls"
    Sheets("Baldwin Park").Select
    Cells.Cells.EntireColumn.AutoFit
    Columns("H:H").Copy
    Columns("BO:BO").Select
    ActiveSheet.Paste
    
    Columns("P:P").Copy
    Columns("BP:BP").Select
    ActiveSheet.Paste
    Columns("BJ:BJ").Copy
    Columns("A:A").Select
    ActiveSheet.Paste
    Columns("BH:BI").Copy
    Columns("B:B").Select
    ActiveSheet.Paste
    
    Columns("BP:BP").Copy
    Columns("D:D").Select
    ActiveSheet.Paste
   
    Columns("R:U").Copy
    Columns("E:E").Select
    ActiveSheet.Paste
    Columns("X:AF").Copy
    Columns("I:I").Select
    ActiveSheet.Paste
   
    Columns("AL:AL").Copy
    Columns("R:R").Select
    ActiveSheet.Paste
 
    Columns("AR:AS").Copy
    Columns("S:S").Select
    ActiveSheet.Paste
   
    Columns("BO:BO").Copy
    Columns("U:U").Select
    ActiveSheet.Paste
    
    Columns("V:BJ").Delete
    Columns("Z:AB").Delete
   
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("Cash Drawer").Select
    LASTROW = Range("A65536").End(xlUp).Row
    Range(Cells(2, "a"), Cells(LASTROW, "y")).Delete
    
    Windows("Cadence cash drawer Response by MSA.xls").Activate
    LASTROW = Range("a65536").End(xlUp).Row
    Range(Cells(2, "a"), Cells(LASTROW, "Y")).Copy
    
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("Cash Drawer").Select
    Range("A2").Select
    ActiveSheet.Paste
    
    Sheets("Cash Drawer").Select
    Cells.EntireColumn.AutoFit
    Columns("Y:Y").ColumnWidth = 20
    Columns("E:E").HorizontalAlignment = xlLeft
    Columns("G:S").NumberFormat = "$#,##0.00_);[Red]($#,##0.00)"
    Range("A1").Select
    
' *************************************************************************************************************
'                  PART VIII - TAB "OVERSHORT"
' *************************************************************************************************************
        
    
    
      Workbooks.Open Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Card Website\Over-Short from CARD.xls"
    Cells.Copy
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("Over_Short Data").Visible = True
    Sheets("Over_Short Data").Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("OverShort").PivotTables("Felix3").PivotCache.Refresh
    Sheets("OverShort").Select
    Columns("B:L").WrapText = True: Columns("B:L").ColumnWidth = 10
    Columns("C:L").HorizontalAlignment = xlRight
    Rows("3:3").EntireRow.AutoFit: Rows("3:3").HorizontalAlignment = xlCenter
    Sheets("Over_Short Data").Visible = False
    
' *************************************************************************************************************
'                  PART IX - TAB "BRINKS OVERSHORT"
' *************************************************************************************************************
    
    Workbooks.Open Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Card Website\Armored from CARD.xls"
    Cells.Copy
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("Brinks Data").Visible = True
    Sheets("Brinks Data").Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Brinks OverShort").PivotTables("Felix4").PivotCache.Refresh
    Sheets("Brinks OverShort").Select
    Columns("B:E").WrapText = True: Columns("B:E").ColumnWidth = 10
    Columns("C:E").HorizontalAlignment = xlRight
    Rows("3:3").EntireRow.AutoFit: Rows("3:3").HorizontalAlignment = xlCenter
    Sheets("Brinks Data").Visible = False
    
' *************************************************************************************************************
'                  PART X - TAB "OPEN DRAWER"
' *************************************************************************************************************
Workbooks.Open Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Card Website\Open Drawer from CARD.xls"
Sheets("Sheet1").Select
Columns("O:O").NumberFormat = "mm/dd/yy;@"
Columns("O:O").HorizontalAlignment = xlCenter
LASTROW = Range("a" & Rows.Count).End(xlUp).Row
For k = 2 To LASTROW
If Range("G" & k) Like "*KIOSK*" Then Range("O" & k) = Range("A" & k)
Next k
    Columns("O:O").Sort Key1:=Range("O1"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
        
For kk2 = 1 To 15
LASTROW = Range("o" & Rows.Count).End(xlUp).Row
For kk = 1 To LASTROW
If Cells(kk, "o") = Cells(kk + 1, "o") Then Cells(kk + 1, "o").Delete
Next kk
Next kk2
Sheets("Sheet2").Select
Columns("A:A").NumberFormat = "mm/dd/yy;@"
Columns("A:A").HorizontalAlignment = xlCenter
Sheets("Sheet1").Select
    Columns("O:O").Copy
Sheets("Sheet2").Select
    Columns("A:A").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
        
For rr2 = 1 To 15
Sheets("Sheet1").Select
Columns("O:O").Delete
LASTROW = Range("a" & Rows.Count).End(xlUp).Row
    For r = LASTROW To 2 Step -1
    If Range("A" & r).Value = Sheets("Sheet2").Range("A1").Value Then Rows(r).Delete
    Next r
Sheets("Sheet2").Range("a1").Delete Shift:=xlUp
Next rr2
   
LASTROW = Range("a" & Rows.Count).End(xlUp).Row
For k2 = LASTROW To 2 Step -1
If Cells(k2, "e") = "Emergency" Then Rows(k2).Delete
If Cells(k2, "e") Like "Anesthesiology-Outpatient*" Then Rows(k2).Delete
If Cells(k2, "e") Like "Med/Surge*" Then Rows(k2).Delete
Next k2
  
Sheets("Sheet1").Select
    Cells.Copy
    Windows("G-BP Monthly POS Review.xls").Activate
    Sheets("Open Drawer Data").Visible = True
    Sheets("Open Drawer Data").Select
    Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Open Drawer").PivotTables("Felix5").PivotCache.Refresh
    Sheets("Open Drawer").Select
    Columns("B:F").WrapText = True: Columns("B:F").ColumnWidth = 10
    Columns("C:F").HorizontalAlignment = xlRight
    Rows("3:3").EntireRow.AutoFit: Rows("3:3").HorizontalAlignment = xlCenter
    Sheets("Open Drawer Data").Visible = False
    Sheets("Monthly Dashboard").Select
    
Application.DisplayAlerts = False
Workbooks("Open Drawer from CARD").Close
Application.DisplayAlerts = False
Workbooks("Armored from CARD").Close
Application.DisplayAlerts = False
Workbooks("Over-Short from CARD").Close
Application.DisplayAlerts = False
Workbooks("Cadence cash drawer Response by MSA").Close
Application.DisplayAlerts = False
Workbooks("Void From Card").Close
Application.DisplayAlerts = False
Workbooks("WIKI Copay Report").Close
Application.DisplayAlerts = False
Workbooks("SCAL Hospital Copay").Close
Application.DisplayAlerts = False
Workbooks("Baldwin Park Pos Collection").Close
Application.DisplayAlerts = False

' ************************************************************************************************************
'                  PART XI - SMALL SPREADSHEET: POS Collection.xls
' ************************************************************************************************************'
    
    Windows("SCAL MOB POS Collection.xls").Activate
    Sheets("RegByType").Select
    Range("L10").Interior.ColorIndex = 15
    LASTROW = Range("d" & Rows.Count).End(xlUp).Row
    For f1 = 11 To LASTROW
    Cells(f1, "l").Interior.ColorIndex = 2
    If Cells(f1, "l") <> "0" And Cells(f1, "l") < "0.965" Then Cells(f1, "l").Font.Bold = True: Cells(f1, "l").Font.ColorIndex = 3: Cells(f1, "l").Interior.ColorIndex = 19
    If Cells(f1, "b") Like "*Total" Then Cells(f1, "l").Interior.ColorIndex = 16
    If Cells(f1, "b") = "Grand Total" Then Cells(f1, "l").Interior.ColorIndex = 1: Cells(f1, "l").Font.ColorIndex = 2
    Next f1
    
    Range("J:J").NumberFormat = "$#,##0": Range("K:K").NumberFormat = "$#,##0"
    Range("M:M").NumberFormat = "$#,##0": Range("N:N").NumberFormat = "$#,##0"
    Range("I:I").NumberFormat = "0%": Range("L:L").NumberFormat = "0%": Range("O:O").NumberFormat = "0%"
    Range("P:P").NumberFormat = "0.0%"
    
    Sheets("RegByDept").Select
    Range("L10").Interior.ColorIndex = 15
    LASTROW = Range("d" & Rows.Count).End(xlUp).Row
    For f2 = 11 To LASTROW
    Cells(f2, "l").Interior.ColorIndex = 2
    If Cells(f2, "l") <> "0" And Cells(f2, "l") < "0.965" Then Cells(f2, "l").Font.Bold = True: Cells(f2, "l").Font.ColorIndex = 3: Cells(f2, "l").Interior.ColorIndex = 19
    If Cells(f2, "b") Like "*Total" Then Cells(f2, "l").Interior.ColorIndex = 16
    If Cells(f2, "b") = "Grand Total" Then Cells(f2, "l").Interior.ColorIndex = 1: Cells(f2, "l").Font.ColorIndex = 2
    Next f2
    Range("J:J").NumberFormat = "$#,##0": Range("K:K").NumberFormat = "$#,##0"
    Range("M:M").NumberFormat = "$#,##0": Range("N:N").NumberFormat = "$#,##0"
    Range("I:I").NumberFormat = "0%": Range("L:L").NumberFormat = "0%": Range("O:O").NumberFormat = "0%"
    Range("P:P").NumberFormat = "0.0%"
   
   Sheets("Trend").Shapes("BP").Select
    Application.Goto Reference:="ShowBP": ActiveCell.FormulaR1C1 = "true"
    Application.Goto Reference:="ShowBF": ActiveCell.FormulaR1C1 = "true"
    Application.Goto Reference:="ShowSB": ActiveCell.FormulaR1C1 = "true"
    
    Sheets("RegByType").Select
    Range("A1").Select
  
Windows("G- Coll by Loc-Dept-User.xls").Activate
' Save Files
Application.DisplayAlerts = False
Workbooks("G- Coll by Loc-Dept-User.xls").SaveAs Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Completed Reports\Collection By Loc-Dept-User\" _
& Workbooks("Monthly Sox Report Macro.xls").Sheets("Macro").Range("j2") & " Collection By Loc-Dept-User.xls"
ActiveWorkbook.Close
Application.DisplayAlerts = False
Workbooks("G-BP Monthly POS Review.xls").SaveAs Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Completed Reports\G-BP Month POS Review\G-BP " _
& Workbooks("Monthly Sox Report Macro.xls").Sheets("Macro").Range("j2") & " Monthly POS Review.xls"
Workbooks("G-BP " & Workbooks("Monthly Sox Report Macro.xls").Sheets("Macro").Range("j2") & " Monthly POS Review.xls").Close
Application.DisplayAlerts = False
Workbooks("SCAL MOB POS Collection.xls").SaveAs Filename:="P:\Microsoft Excel\Projects\Monthly SOX Report\Completed Reports\POS Collection\POS Collection " _
& Workbooks("Monthly Sox Report Macro.xls").Sheets("Macro").Range("j2")
Workbooks("POS Collection " & Workbooks("Monthly Sox Report Macro.xls").Sheets("Macro").Range("j2")).Close
 
Windows("Monthly Sox Report Macro.xls").Activate
Sheets("Random").Visible = False
MsgBox ("REPORT COMPLETED")
End Sub

Andrew Poulsom · Sep 20, 2011

I would update the progress bar before each of your PARTS.

Faking an animated image in a userform?

BBrandt

Board Regular

BBrandt

Board Regular

Excel Facts

MickG

MrExcel MVP

Legacy 98055

Guest

BBrandt

Board Regular

Legacy 98055

Guest

BBrandt

Board Regular

fpskidmark

Board Regular

Andrew Poulsom

MrExcel MVP

fpskidmark

Board Regular

Andrew Poulsom

MrExcel MVP

Similar threads

Forum statistics

Share this page

Faking an animated image in a userform?

Board Regular

Board Regular

Excel Facts

MrExcel MVP

Legacy 98055

Guest

Board Regular

Legacy 98055

Guest

Board Regular

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock