Braunschweiger
Board Regular
- Joined
- Feb 19, 2014
- Messages
- 104
I'm trying to close my progress bar after 3 seconds and have searched and searched and tried several scripts and can't get it to work. Can someone please show me the light!?!
The "Call" Script is at the end as well as the Userform Scripts.
Thanks a TON in advance!!!
The "Call" Script is at the end as well as the Userform Scripts.
Thanks a TON in advance!!!
VBA Code:
Sub AE_Contact_REAC_Report_TEST()
'1111
Call InitProgressBar1
DoEvents
Call SR01_ClearFrozenPanesClearFilters
Call InitProgressBar2
DoEvents
Call SR02_CopyColumnsPortfolioSnapshot
Call InitProgressBar3
DoEvents
Call SR03_RequiredREACMiddleAlignment
Call InitProgressBar4
DoEvents
Unload Progress
End Sub
Sub SR01_ClearFrozenPanesClearFilters()
Application.ScreenUpdating = False
'Clear Frozen Panes & Clear Filters
Dim wb As Workbook
Set wb = Workbooks("HUD_232_Portfolio_AE_Assignments - MACRO Build Document.xlsm")
Dim ws As Worksheet
Set ws = wb.Worksheets("Account Executive Assignments")
ws.Activate
ws.Range("A1").Select
ActiveWindow.FreezePanes = False
If ActiveSheet.AutoFilterMode Then
ActiveSheet.AutoFilterMode = False
End If
ws.Range("A1").Select
'Clear Data & Formatting
ws.Range("A1").Select
ws.Range("B8").Select
Range(Selection, Selection.End(xlToRight)).Offset(1, 0).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Selection.Interior.Pattern = x1None
ws.Range("A1").Select
End Sub
Sub SR02_CopyColumnsPortfolioSnapshot()
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = Workbooks("HUD_232_Portfolio_AE_Assignments - MACRO Build Document.xlsm")
Dim ws As Worksheet
Set ws = wb.Worksheets("Account Executive Assignments")
Dim wbps As Workbook
Set wbps = Workbooks.Open _
("C:\Users\david\Dropbox\David's Stuff\Work Stuff\VBA Source Documents\Portfolio Snapshot.xlsx")
Dim wsps As Worksheet
Set wsps = wbps.Worksheets("Projects Only")
Call Progress.Show(vbModeless)
Dim i As Long
Application.DisplayAlerts = False
wsps.Activate
wsps.Range("A2:B2").Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("B9").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsps.Activate
wsps.Range("A2").Offset(0, 4).Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("E9").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsps.Activate
wsps.Range("A2").Offset(0, 34).Resize(1, 2).Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("F9").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsps.Activate
wsps.Range("A2").Offset(0, 39).Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("H9").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsps.Activate
wsps.Range("A2").Offset(0, 41).Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("I9").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsps.Activate
wsps.Range("A2").Offset(0, 40).Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("J9").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsps.Activate
wsps.Range("A2").Offset(0, 2).Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("K9").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsps.Activate
wsps.Range("A2").Offset(0, 3).Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("N9").Select
Selection.PasteSpecial Paste:=xlPasteValues
wsps.Activate
wsps.Range("A2").Offset(0, 16).Select
wsps.Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
wb.Activate
ws.Range("S9").Select
ws.Paste
Workbooks("Portfolio Snapshot.xlsx").Close SaveChanges:=False
ws.Activate
ws.Range("A1").Select
End Sub
Sub SR03_RequiredREACMiddleAlignment()
Dim wb As Workbook
Set wb = Workbooks("HUD_232_Portfolio_AE_Assignments - MACRO Build Document.xlsm")
Dim ws As Worksheet
Set ws = wb.Worksheets("Account Executive Assignments")
For i = 9 To Rows.Count
If Cells(i, 2).Value <> "" Then
Cells(i, 2).Offset(0, 17).Select
If (ActiveCell.Value = "223(a)(7) Refi of 223f Nursing/ ICF") _
Or (ActiveCell.Value = "223(a)(7) Refi of 232 NC/SR Nursing/ ICF") _
Or (ActiveCell.Value = "223(f) Refi/ Purchase of 232 Nursing/ ICF") _
Or (ActiveCell.Value = "232 NC/SR Nursing/ ICF") _
Or (ActiveCell.Value = "241a Improvement/ Addition on 232 Nursing/ ICF") _
Or (ActiveCell.Value = "223d 2yr Operating Loss for 232 Nursing/ ICF") _
Or (ActiveCell.Value = "232 Nursing Homes - Delegated") _
Or (ActiveCell.Value = "232 NC/SR Nursing/ICF in a 223(e) Declining Area") _
Or (ActiveCell.Value = "232 NC/SR Nursing/ ICF in a 223(e) Declining Area") Then
ActiveCell.Offset(0, -2).Select
Selection = "NO"
Selection.Font.Bold = True
Selection.Font.ThemeColor = xlThemeColorDark1
Selection.Interior.Color = 255
End If
If (ActiveCell.Value = "223(a)(7) Refi of 241a loan on 232 Health Care Facility") _
Or (ActiveCell.Value = "232(i) Fire safety Equipment on 232 Health Care Facility") _
Or (ActiveCell.Value = "223(a)(7) Refi of Operating Loss on 232 Health Care Facility") _
Or (ActiveCell.Value = "232 NC/SR Asst'd Living") _
Or (ActiveCell.Value = "223(a)(7) Refi of 223f ALF") _
Or (ActiveCell.Value = "223(a)(7) Refi of 232 NC/SR Asst'd Living") _
Or (ActiveCell.Value = "223(a)(7) Refi of 232 NC/SR Board & Care") _
Or (ActiveCell.Value = "232 NC/SR Board & Care") _
Or (ActiveCell.Value = "241a Improvement/ Addition on 232 Asst'd Living") _
Or (ActiveCell.Value = "223(a)(7) Refi of 223f B & C") _
Or (ActiveCell.Value = "223d 2yr Operating Loss on 232 Board & Care") _
Or (ActiveCell.Value = "223(f) Refi/ Purchase of 232 Asst'd Living") _
Or (ActiveCell.Value = "241a Improvement/ Addition on 232 Board & Care") _
Or (ActiveCell.Value = "223(f) Refi/ Purchase of 232 Board & Care") _
Or (ActiveCell.Value = "223d 2yr Operating Loss on 232 Asst'd Living") Then
ActiveCell.Offset(0, -2).Select
Selection = "YES"
Selection.Font.Bold = True
Selection.Font.ColorIndex = xlAutomatic
Selection.Interior.Color = 65280
End If
End If
Next i
ws.Columns("S:S").Select
Selection.Delete
Cells.Select
Cells.EntireColumn.AutoFit
ws.Range("A1").Select
ws.Range("B8").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders.LineStyle = xlContinuous
ws.Range("B9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 1).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 2).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 5).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 7).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 8).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 10).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 13).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 15).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Range("B9").Offset(0, 16).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.HorizontalAlignment = xlCenter
ws.Activate
ws.Range("A1").Select
End Sub
'This is where the percent complete comes from
Sub InitProgressBar1()
With Progress
.Bar.Width = 0
.Text.Caption = "0% Complete"
.Show modaless
End With
End Sub
Sub InitProgressBar2()
With Progress
.Bar.Width = 116
.Text.Caption = "30% Complete"
.Show modaless
End With
End Sub
Sub InitProgressBar3()
With Progress
.Bar.Width = 232
.Text.Caption = "60% Complete"
.Show modaless
End With
End Sub
Sub InitProgressBar4()
With Progress
.Bar.Width = 348
.Text.Caption = "100% Complete"
.Show modaless
End With
End Sub
'Userform Code (Currently None)
Private Sub Bar_Click()
End Sub
Private Sub Text_Click()
End Sub
Private Sub UserForm_Click()
End Sub