Progress Bar

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!!!

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
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
I suppose you have the progress bar because your macro takes a long time to process.
It seems better to you, if I make improvements to your macro to make it faster.

Let's start with this line, what it does is go from row 9 to row 1 million.
VBA Code:
  For i = 9 To Rows.Count

Change to this:
VBA Code:
For i = 9 To range("B" & rows.Count).End(3).Row

I'm going to go through all the code and make the improvements.
As you test that change, tell me how long your macro took and now how long it takes.
 
Upvote 0
Replace all your code with the following and test.
It also comments how many rows you have to process. How long did your macro take and how long does it take now.

VBA Code:
Sub SR_All()
  Dim wb As Workbook, ws As Worksheet, wbps As Workbook, wsps As Worksheet
  Dim sPath As String, sFile As String
  Dim lr As Long, i As Long
  
  Application.ScreenUpdating = False
  sPath = "C:\Users\david\Dropbox\David's Stuff\Work Stuff\VBA Source Documents\"
  sFile = "Portfolio Snapshot.xlsx"
  
  Set wb = Workbooks("HUD_232_Portfolio_AE_Assignments - MACRO Build Document.xlsm")
  Set ws = wb.Worksheets("Account Executive Assignments")
  Set wbps = Workbooks.Open(sPath & sFile)
  Set wsps = wbps.Worksheets("Projects Only")
  
  If ws.AutoFilterMode Then ws.AutoFilterMode = False
  With ws.Range("B9", ws.Cells(Rows.Count, Columns.Count))
    .ClearContents
    .Interior.Pattern = xlNone
  End With

  lr = wsps.Range("A2").End(4).Row
  ws.Range("B9").Resize(lr - 1, 2).Value = wsps.Range("A2:B" & lr).Value
  ws.Range("E9").Resize(lr - 1, 1).Value = wsps.Range("E2:E" & lr).Value
  ws.Range("F9").Resize(lr - 1, 1).Value = wsps.Range("AI2:AI" & lr).Value
  ws.Range("H9").Resize(lr - 1, 1).Value = wsps.Range("AN2:AN" & lr).Value
  ws.Range("I9").Resize(lr - 1, 1).Value = wsps.Range("AP2:AP" & lr).Value
  ws.Range("J9").Resize(lr - 1, 1).Value = wsps.Range("AO2:AO" & lr).Value
  ws.Range("K9").Resize(lr - 1, 1).Value = wsps.Range("C2:C" & lr).Value
  ws.Range("N9").Resize(lr - 1, 1).Value = wsps.Range("D2:D" & lr).Value
  ws.Range("S9").Resize(lr - 1, 1).Value = wsps.Range("Q2:Q" & lr).Value
  wbps.Close False
  
  lr = ws.Range("B" & Rows.Count).End(3).Row
  For i = 9 To lr
    If ws.Range("B" & i).Value <> "" Then
      Select Case ws.Range("S" & i).Value
      Case "223(a)(7) Refi of 223f Nursing/ ICF", _
           "223(a)(7) Refi of  232 NC/SR Nursing/ ICF", _
           "223(f) Refi/ Purchase of 232 Nursing/ ICF", _
           "232 NC/SR Nursing/ ICF", _
           "241a Improvement/ Addition on 232 Nursing/ ICF", _
           "223d 2yr Operating Loss for 232 Nursing/ ICF", _
           "232 Nursing Homes - Delegated", _
           "232 NC/SR Nursing/ICF in a 223(e) Declining Area", _
           "232 NC/SR Nursing/ ICF in a 223(e) Declining Area"
          With ws.Range("Q" & i)
            .Value = "NO"
            .Font.Bold = True
            .Font.ThemeColor = xlThemeColorDark1
            .Interior.Color = 255
          End With
      Case "223(a)(7) Refi of 241a loan on 232 Health Care Facility", _
           "232(i) Fire safety Equipment on 232 Health Care Facility", _
           "223(a)(7) Refi of Operating Loss on 232 Health Care Facility", _
           "232 NC/SR Asst'd Living", _
           "223(a)(7) Refi of 223f ALF", _
           "223(a)(7) Refi of 232 NC/SR Asst'd Living", _
           "223(a)(7) Refi of 232 NC/SR Board & Care", _
           "232 NC/SR Board & Care", _
           "241a Improvement/ Addition on 232 Asst'd Living", _
           "223(a)(7) Refi of 223f B & C", _
           "223d 2yr Operating Loss on 232 Board & Care", _
           "223(f) Refi/ Purchase of 232 Asst'd Living", _
           "241a Improvement/ Addition on 232 Board & Care", _
           "223(f) Refi/ Purchase of 232 Board & Care", _
           "223d 2yr Operating Loss on 232 Asst'd Living"
          With ws.Range("Q" & i)
            .Value = "YES"
            .Font.Bold = True
            .Font.ColorIndex = xlAutomatic
            .Interior.Color = 65280
          End With
      End Select
    End If
  Next i
  ws.Columns("S:S").Delete
  ws.Cells.EntireColumn.AutoFit
  
  ws.Range("B8:R" & lr).Borders.LineStyle = xlContinuous
  With ws.Range("B9:D" & lr & ", G9:G" & lr & ", I9:I" & lr & _
        ", J9:J" & lr & ", L9:L" & lr & ", O9:O" & lr & ", Q9:S" & lr)
    .HorizontalAlignment = xlCenter
  End With
End Sub
 
Upvote 0
I suppose you have the progress bar because your macro takes a long time to process.
It seems better to you, if I make improvements to your macro to make it faster.

Let's start with this line, what it does is go from row 9 to row 1 million.
VBA Code:
  For i = 9 To Rows.Count

Change to this:
VBA Code:
For i = 9 To range("B" & rows.Count).End(3).Row

I'm going to go through all the code and make the improvements.
As you test that change, tell me how long your macro took and now how long it takes.

WOW!!! Thanks a TON! It cut the time in half. I haven't tried the second part yet. The main purpose of my exercise is to learn the Progress Bar. Your solution not only sped up my MACRO but...smoothed out the Progress Bar. Meaning, I was getting a couple "Excel Not Responding" alerts and then it would continue to run. With you script...it got rid of all that.

Thanks much and I appreciate the lesson...the 9 to 1 million.

I'll try your second solution in a bit and let you know.

Now...I've gotta figure out how to remove the Progress Bar Header.
 
Upvote 0
The main purpose of my exercise is to learn the Progress Bar.
Check my post #6 on this link:

Try to adapt it to your code, you will have a progressbar with an advance every 5 records.

How many records do you have in your file, maybe I can adjust the macro in post #3 to make it faster.
 
Upvote 0
Check the following macro, it should be faster than the previous ones.

VBA Code:
Sub SR_All()
  Dim wb As Workbook, ws As Worksheet, wbps As Workbook, wsps As Worksheet
  Dim sPath As String, sFile As String
  Dim lr As Long, i As Long, a As Variant
 
  Application.ScreenUpdating = False
  sPath = "C:\Users\david\Dropbox\David's Stuff\Work Stuff\VBA Source Documents\"
  sFile = "Portfolio Snapshot.xlsx"
 
  Set wb = Workbooks("HUD_232_Portfolio_AE_Assignments - MACRO Build Document.xlsm")
  Set ws = wb.Worksheets("Account Executive Assignments")
  Set wbps = Workbooks.Open(sPath & sFile)
  Set wsps = wbps.Worksheets("Projects Only")
 
  If ws.AutoFilterMode Then ws.AutoFilterMode = False
  With ws.Range("B9", ws.Cells(Rows.Count, Columns.Count))
    .ClearContents
    .Interior.Pattern = xlNone
  End With

  lr = wsps.Range("A2").End(4).Row
  ws.Range("B9").Resize(lr - 1, 2).Value = wsps.Range("A2:B" & lr).Value
  ws.Range("E9").Resize(lr - 1, 1).Value = wsps.Range("E2:E" & lr).Value
  ws.Range("F9").Resize(lr - 1, 1).Value = wsps.Range("AI2:AI" & lr).Value
  ws.Range("H9").Resize(lr - 1, 1).Value = wsps.Range("AN2:AN" & lr).Value
  ws.Range("I9").Resize(lr - 1, 1).Value = wsps.Range("AP2:AP" & lr).Value
  ws.Range("J9").Resize(lr - 1, 1).Value = wsps.Range("AO2:AO" & lr).Value
  ws.Range("K9").Resize(lr - 1, 1).Value = wsps.Range("C2:C" & lr).Value
  ws.Range("N9").Resize(lr - 1, 1).Value = wsps.Range("D2:D" & lr).Value
  ws.Range("S9").Resize(lr - 1, 1).Value = wsps.Range("Q2:Q" & lr).Value
  wbps.Close False
 
  lr = ws.Range("B" & Rows.Count).End(3).Row
  a = ws.Range("B9:S" & lr).Value2
  For i = 1 To UBound(a)
    If a(i, 1) <> "" Then
      Select Case a(i, 18)
      Case "223(a)(7) Refi of 223f Nursing/ ICF", _
           "223(a)(7) Refi of  232 NC/SR Nursing/ ICF", _
           "223(f) Refi/ Purchase of 232 Nursing/ ICF", _
           "232 NC/SR Nursing/ ICF", _
           "241a Improvement/ Addition on 232 Nursing/ ICF", _
           "223d 2yr Operating Loss for 232 Nursing/ ICF", _
           "232 Nursing Homes - Delegated", _
           "232 NC/SR Nursing/ICF in a 223(e) Declining Area", _
           "232 NC/SR Nursing/ ICF in a 223(e) Declining Area"
           a(i, 16) = "NO"
      Case "223(a)(7) Refi of 241a loan on 232 Health Care Facility", _
           "232(i) Fire safety Equipment on 232 Health Care Facility", _
           "223(a)(7) Refi of Operating Loss on 232 Health Care Facility", _
           "232 NC/SR Asst'd Living", _
           "223(a)(7) Refi of 223f ALF", _
           "223(a)(7) Refi of 232 NC/SR Asst'd Living", _
           "223(a)(7) Refi of 232 NC/SR Board & Care", _
           "232 NC/SR Board & Care", _
           "241a Improvement/ Addition on 232 Asst'd Living", _
           "223(a)(7) Refi of 223f B & C", _
           "223d 2yr Operating Loss on 232 Board & Care", _
           "223(f) Refi/ Purchase of 232 Asst'd Living", _
           "241a Improvement/ Addition on 232 Board & Care", _
           "223(f) Refi/ Purchase of 232 Board & Care", _
           "223d 2yr Operating Loss on 232 Asst'd Living"
           a(i, 16) = "YES"
      End Select
    End If
  Next i
  ws.Range("B9").Resize(UBound(a, 1), UBound(a, 2)).Value = a
  ws.Columns("S:S").Delete
  ws.Cells.EntireColumn.AutoFit
 
  ws.Range("B8:R" & lr).Borders.LineStyle = xlContinuous
  With ws.Range("B9:D" & lr & ", G9:G" & lr & ", I9:I" & lr & _
        ", J9:J" & lr & ", L9:L" & lr & ", O9:O" & lr & ", Q9:S" & lr)
    .HorizontalAlignment = xlCenter
  End With
  '
  With Application.ReplaceFormat
    .Clear
    .Font.Bold = True
    .Font.ThemeColor = xlThemeColorDark1
    .Interior.Color = 255
    ws.Range("Q9:Q" & lr).Replace "NO", "", xlPart, xlByRows, False, , False, True
    .Font.ColorIndex = xlAutomatic
    .Interior.Color = 65280
    ws.Range("Q9:Q" & lr).Replace "YES", "", xlPart, xlByRows, False, , False, True
    .Clear
  End With
End Sub
 
Upvote 0
FYI...I'm just about finished with my file and it works...I just don't know how efficient it is. So, once I'm totally finished...I'll send you the actual Excel spreadsheet and I'll try and send you the feeder files so you can actually run it. Just if you have time and want to...if not, I totally understand! All the information I'll be sending is public information...once I'm done with the spreadsheet I have it uploaded to FHA.gov - I'll send you the actual link. If you couldn't tell...I work for HUD (please don't hold it against me...lol).

Dave

Actually...here it is:
ORCF Loan Servicing | HUD.gov / U.S. Department of Housing and Urban Development (HUD)

AECR Location.JPG
 
Upvote 0

Forum statistics

Threads
1,224,598
Messages
6,179,818
Members
452,946
Latest member
JoseDavid

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