Faking an animated image in a userform?

B

BBrandt

Board Regular
Joined
Jul 14, 2008
Messages
155
I've gathered that it's not possible to place an animated GIF like this:

progressbarpf7.gif


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!
 
Sort by date Sort by votes
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.
 
Upvote 0

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
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
 
Upvote 0
<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
 
Last edited by a moderator:
Upvote 0
:eek:

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!
 
Upvote 0
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. :)
 
Last edited by a moderator:
Upvote 0
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 :biggrin:.

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!
 
Upvote 0
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
Click to expand...
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

G
  • Question
Trouble pre-setting userform values based off user input
Replies
2
Views
114
gc2001
G
D
  • Question
Working with images in VBA - Image Properties
Replies
2
Views
5K
Jaafar Tribak
Jaafar Tribak
R
  • Question
VBA Progress bar
Replies
4
Views
759
Rhemo
R
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
454
AndyEd
A
K
  • Question
help with VBA to find specific text within a string and within a specific range
Replies
1
Views
2K
kbishop94
K

Forum statistics

Threads
1,215,580
Messages
6,125,654
Members
449,245
Latest member
PatrickL

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