adding a progress bar

[Djblois]

Another thing I would like to add to my code is a progress bar, so people know it didn't lock up. Is this possible and if it is can someone help me create it in my code.

[lucas]

http://vbaexpress.com/kb/getarticle.php?kb_id=411
http://vbaexpress.com/kb/getarticle.php?kb_id=169
http://vbaexpress.com/kb/getarticle.php?kb_id=87

[jungix]

If a simple toolbar is enough for you just use

Application.StatusBar = "yourtexthere"

[Justinlabenne]

Attached in the Zip file is a class module you can import into your project and use throughout:

You implement it like this, declare an Instance of "StatusProgress", then set all it's properties, show it, increment it's progress in your loop, Close it, then clear all memory to it.

[VBA]Option Explicit

Public Sub TestProgessBar()
Dim x As Long
Dim n As Long


Dim f As StatusProgress 'Instantiate our status bar
Set f = New StatusProgress

With f

.MaxProgress = 500 'Maximum progress to be used

.Style = Style1 'Style for the status bar

.Color = NavyBlue 'Status color

'.BackColor = White

.BarType = Smooth ' Led / Smooth

.ProgressShow 'Show it!



For x = 1 To .MaxProgress

For n = 1 To 1000000 'These 2 lines slow the loop down
Next n 'Replace with your code here

.Progress x 'Increment progress
Next x


.ProgressFinish 'Reset the status bar
End With

Set f = Nothing 'Clear memory
End Sub[/VBA]

[Bob Phillips]

See http://www.enhanceddatasystems.com/E...rogressBar.htm

[asingh]

The method you used to "slow" down the progress bar is really great. I used to face a problem..where I wanted the Progress bar "PROGRESS" to be visible to the users for a while..and not just vanish in a blink of a VBA-Code FOR - NEXT Loop...! I used to use "Application.Wait (Now + TimeValue("0:00:01"))"
to slow down the process for a while, but at times it made the whole Form a bit slow. Using the Loop with "n" to slightly slow the process is great....!

regards,

asingh

[Djblois]

Attached in the Zip file is a class module you can import into your project and use throughout:

You implement it like this, declare an Instance of "StatusProgress", then set all it's properties, show it, increment it's progress in your loop, Close it, then clear all memory to it.

[vba]Option Explicit

Public Sub TestProgessBar()
Dim x As Long
Dim n As Long


Dim f As StatusProgress 'Instantiate our status bar
Set f = New StatusProgress

With f

.MaxProgress = 500 'Maximum progress to be used

.Style = Style1 'Style for the status bar

.Color = NavyBlue 'Status color

'.BackColor = White

.BarType = Smooth ' Led / Smooth

.ProgressShow 'Show it!



For x = 1 To .MaxProgress

For n = 1 To 1000000 'These 2 lines slow the loop down
Next n 'Replace with your code here

.Progress x 'Increment progress
Next x


.ProgressFinish 'Reset the status bar
End With

Set f = Nothing 'Clear memory
End Sub[/vba]

I am sorry for not understanding but I am new to VBA. How do I Add this to my code.

Daniel

[Justinlabenne]

I don't know what your code is. Here is a slight reworking that hopefully helps a bit more:

[VBA]Option Explicit

Public Sub DjbloisCode()
Dim spStatBar As StatusProgress
Set spStatBar = New StatusProgress

'Set up all the properties of the progress bar
With spStatBar
.Style = Style1
.Color = NavyBlue
.BarType = Smooth
.MaxProgress = 500


.ProgressShow 'Show the progress bar when necessary




'your code goes here!!!
'Somewhere in your code increment the progress bar with a variable
'(x represents a number)
.Progress x
'your code goes here!!!




.ProgressFinish 'This resets the statusbar
End With

Set spStatBar = Nothing
End Sub[/VBA]

What you need to do is make sure you have imported the class module that was in the zip file. Within your code, add the lines:
[VBA] Dim spStatBar As StatusProgress
Set spStatBar = New StatusProgress

'Set up all the properties of the progress bar
With spStatBar
.Style = Style1
.Color = NavyBlue
.BarType = Smooth [/VBA]
That will set the bar up before it's shown. You then need to set the maximum progress you will be using
[VBA].MaxProgress = 500[/VBA]

The MaxProgress would be the highest number in a loop you suspect your code will encounter. Then within your code you need to show the progress bar,
[VBA].ProgressShow[/VBA]

and then increment it somewhere in your code:
[VBA].Progress 10
.Progress 20[/VBA]

When your code is finished, reset the statusbar, and clear memory:
[VBA] .ProgressFinish
End With

Set spStatBar = Nothing[/VBA]

Attach your Excel file or a sample of your code if you need more help.

[Djblois]

I added the code like you said but I keep getting an error on this line
[VBA]Dim spStatBar As StatusProgress[/VBA]

This is the error I am getting: user-defined type not defined

[Djblois]

Here is my code

[vba]Option Explicit
Sub Blinco()
'
' Macro1 Macro
' Macro recorded 5/19/2006 by Dblois
' Version .9 Changes
'Foundational - Clean up Customer and Products tabs
'Foundational - Cust and Product sheets now move over only one row for cleanup
'Foundational - Does not add "XWhse" to Del column to look cleaner
'Bug Fix - If Div/0 then "No Sale" will show instead of error
'Bug Fix - will now fill whole Column for Product, Dept, and % all the time
'Foundational - Fixed the logical order of the code
'Foundational - Item# column is now formated "00-0000"
'Foundational - Added Version# to first Input Box
' Version 1.0 Changes
'Foundational - Slightly Modified code for simplicity
'Foundational - Will now Name 1st tab summary for future features
'Feature - Will now check if saving over existing file
'Feature - Will now Sort By Customer Then Product Then Date at end of Macro
'Feature - Will now Freeze row 1
'Feature - Will now coditionally format column "T"
'Will color Yellow if "No Sale"
'Will color Dark Yellow if less than 0
'Foundational - Will now add Sheets only if needed for customer and product list
'Foundational - Will now add conditional formating at the same time as % formula
'Foundational - Will now add Atalanta to the header instead of Grocery Dept.
' Version 1.2 Changes
'Feature - Will now add Invoice, Whse, Customer, Salesperson, and Product Summary sheets
'Foundational - Moved File save to the beginning
'Foundational - Corrected the logic in sorting
'Foundational - Simplified code needed for Formulas
'Foundational - Removed unnessecary code
' Version 1.5 Changes
'Foundational - Will now check to see if Atalanta codes is open before it opens it
'Feature - Will now leave Atalanta codes open if it was originally open
'Feature - Will now look in Atalanta codes before cust tab
'Feature - Will now look in Atalanta codes before prod tab
'Foundational - Will not show #N/A in Dept column if it can't find it.
' Version 1.7 Changes
'Feature - Will now make a system beep when it is finished
'Set Variables
Dim WB As Workbook, Detail As Worksheet, Cust As Worksheet, Prod As Worksheet
Dim rngFind As Range, MyInput As String
'Dim spStatBar As StatusProgress
Set WB = ActiveWorkbook
Set Detail = WB.ActiveSheet
'Set spStatBar = New StatusProgress

'Begin Macro
Detail.Name = "Detail"
MyInput = InputBox("Version 1.5:What do you want to name the File?")
ActiveWorkbook.SaveAs "H:\@temp\Daniel B\Current Projects\" & MyInput
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.StatusBar = "Please be Patient while the Macro Runs!"
'With spStatBar
'.Style = Style1
'.Color = NavyBlue
'.BarType = Smooth
' .MaxProgress = 500
' .ProgressShow



'Sort
Detail.Range("A1", ActiveCell.SpecialCells(xlLastCell)).Sort _
Key1:=Range("A1"), Order1:=xlAscending, Header:=xlNo

'Delete extra
Detail.Columns("A:A").Find(What:="AT").Select
Detail.Range(Selection, Selection.End(xlToRight)).Select
Detail.Range(Selection, Selection.End(xlUp)).EntireRow.Delete
'Create Customer tab
Detail.Columns("A:A").Find(What:="Customer:").Select
Detail.Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Cut
If WB.Sheets.Count = 1 Then
Set Cust = WB.Worksheets.Add
Else: Set Cust = WB.Sheets(2)
End If
ActiveSheet.Name = "Cust"
ActiveSheet.Paste

'Remove ) from Data
Cust.Columns("A:B").Replace What:=")", Replacement:=""

'Create Product tab
Set rngFind = Cust.Range("A:A").Find(What:="Product:", After:=Cust.Range("A1"))
Cust.Range(rngFind, Cust.Cells(Cust.Rows.Count, rngFind.Column)).Cut
If WB.Sheets.Count = 2 Then
Set Prod = WB.Worksheets.Add
Else: Set Prod = WB.Sheets(3)
End If
ActiveSheet.Name = "Prod"
ActiveSheet.Paste

'Create Item# Column in product tab
Prod.Range("B1:B" & Prod.Cells(Prod.Rows.Count, 1).End(xlUp).Row).FormulaR1C1
= "=Mid(RC[-1],10,6)"
Prod.Range("B1:B" & Prod.Cells(Prod.Rows.Count, 1).End(xlUp).Row).Value = _
Prod.Range("B1:B" & Prod.Cells(Prod.Rows.Count, 1).End(xlUp).Row).Value

'Create Products Column in product tab
Prod.Range("C1:C" & Prod.Cells(Prod.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = "
=PROPER(Trim(MID(RC[-2],18,80)))"
Prod.Range("C1:C" & Prod.Cells(Prod.Rows.Count, 1).End(xlUp).Row).Value = _
Prod.Range("C1:C" & Prod.Cells(Prod.Rows.Count, 1).End(xlUp).Row).Value

'Create Cust# Column in customer tab
Cust.Select
Cust.Range("B1:B" & Cust.Cells(Cust.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 =
"=Mid(RC[-1],11,4)"
Cust.Range("B1:B" & Cust.Cells(Cust.Rows.Count, 1).End(xlUp).Row).Value = _
Cust.Range("B1:B" & Cust.Cells(Cust.Rows.Count, 1).End(xlUp).Row).Value
Columns("B:B").TextToColumns Destination:=Range("C1")

'Create Customer Column in customer tab
Cust.Range("C1:C" & Cust.Cells(Prod.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 =
"=PROPER(Trim(MID(RC[-2],17,50)))"
Cust.Range("C1:C" & Cust.Cells(Cust.Rows.Count, 1).End(xlUp).Row).Value = _
Cust.Range("C1:C" & Cust.Cells(Cust.Rows.Count, 1).End(xlUp).Row).Value
Columns("C:C").TextToColumns Destination:=Range("C1")
'.Progress 100

'Clean Bottem of Database
Detail.Cells.AutoFilter field:=1, Criteria1:="Atalanta*"
On Error Resume Next
Detail.Range("A2:A" & Detail.Rows.Count).EntireRow.SpecialCells(xlCellTypeVisible).Delete
Detail.AutoFilterMode = False

'Delete Columns
Detail.Columns("C:C").Delete Shift:=xlToLeft
Detail.Columns("F:F").Delete Shift:=xlToLeft
Detail.Columns("P:V").Delete Shift:=xlToLeft

'Open Atalanta Codes workbook
Dim Codes As Workbook, WasCodesOpen As Boolean
On Error Resume Next
Set Codes = Workbooks("Atalanta Codes.xls")
WasCodesOpen = True
On Error GoTo 0
If Codes Is Nothing Then
Set Codes = Workbooks.Open("H:\@temp\Daniel B\Reference\Atalanta Codes.xls")
WasCodesOpen = False
End If
WB.Activate

'Fix Invoice# (A)
Detail.Rows("1:1").Insert Shift:=xlDown
Detail.Range("A1").FormulaR1C1 = "Invoice#"

'Fix Date (B)
Detail.Range("B1").FormulaR1C1 = "Date"
With Detail.Columns("B:B")
.TextToColumns Destination:=Range("B1")
.NumberFormat = "mm/dd/yy;@"
End With

'Add Warehouses (C)
Detail.Columns("C:C").TextToColumns Destination:=Range("C1")
Detail.Columns("D").Insert Shift:=xlToRight
Detail.Range("D1").FormulaR1C1 = "Whse"
Detail.Range("D2" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]Whses'!C1:C8,2,FALSE)"
Detail.Range("D1" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value = _
Detail.Range("D1" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value
Detail.Columns("C:C").Delete

'Fix Cust# (D)
Detail.Range("D1").FormulaR1C1 = "Cust#"
Detail.Columns("D").TextToColumns Destination:=Range("D1")

'Add Customers (E)
Detail.Columns("E:E").Insert Shift:=xlToRight
Detail.Range("E1").FormulaR1C1 = "Customer"
Detail.Range("E2:E" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-1],'[Atalanta Codes.xls]Cust'!C1:C9,2,FALSE)), VLOOKUP(RC[-1],Cust!C[-3]:
C[-2],2,FALSE), VLOOKUP(Detail!RC[-1],'[Atalanta Codes.xls]Cust'!C1:C9,2,FALSE))"
Detail.Range("E1:E" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value = _
Detail.Range("E1:E" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value
'.Progress 200

'Fix Sls# (F)
Detail.Range("F1").FormulaR1C1 = "Sls#"
Detail.Columns("F:F").TextToColumns Destination:=Range("F1")
Detail.Columns("F:F").EntireColumn.Hidden = True

'Add SlsPrsn (G)
Detail.Columns("G:G").Insert Shift:=xlToRight
Detail.Range("G1").FormulaR1C1 = "SlsPrsn"
Detail.Range("G2:G" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = _
"=VLOOKUP(RC[-1],'[Atalanta Codes.xls]SlsPrsn'!C1:C8,2,FALSE)"
Detail.Range("G1:G" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value = _
Detail.Range("G1:G" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value

'Fix Item# (H)
Detail.Range("H1").FormulaR1C1 = "Item#"
With Detail.Range("H:H")
.TextToColumns Destination:=Range("H1")
.NumberFormat = "00-0000"
End With

'Add Product (I)
Detail.Columns("I:I").Insert Shift:=xlToRight
Detail.Range("I1").FormulaR1C1 = "Product"
Detail.Range("I2:I" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-1],'[Atalanta Codes.xls]Products'!C1:C12,5,FALSE)), VLOOKUP(Detail!RC[-1],Prod!C
[-7]:C[-6],2,FALSE), VLOOKUP(Detail!RC[-1],'[Atalanta Codes.xls]Products'!C1:C12,5,FALSE))"
Detail.Range("I1:I" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value = _
Detail.Range("I1:I" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value

'Add Dept (J)
Detail.Columns("J:J").Insert Shift:=xlToRight
Detail.Range("J1").FormulaR1C1 = "Dept"
Detail.Range("J2:J" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = _
"=IF(ISNA(VLOOKUP(RC[-2],'[Atalanta Codes.xls]Products'!C1:C12,4,FALSE)), """",VLOOKUP(RC[-2],'
[Atalanta Codes.xls]Products'!C1:C12,4,FALSE))"
Detail.Range("J1:J" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value = _
Detail.Range("J1:J" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value
'.Progress 300

'Fix Qty (K)
Detail.Range("K1").FormulaR1C1 = "Qty"
With Detail.Columns("K:K")
.TextToColumns Destination:=Range("K1")
.NumberFormat = "#,##0"
End With

'Fix Units (L)
Detail.Range("L1").FormulaR1C1 = "Units"
With Detail.Columns("L:L")
.TextToColumns Destination:=Range("L1")
.Style = "Comma"
End With

'Fix Price (M)
Detail.Range("M1").FormulaR1C1 = "Price"
With Detail.Columns("M:M")
.TextToColumns Destination:=Range("M1")
.Style = "Comma"
End With

'Add Delivery (N)
Detail.Range("N1").FormulaR1C1 = "Del"
Detail.Range("N2:N" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Replace What:="D", Replacement:=
"
Del"
'Fix Amt (O)
Detail.Range("O1").FormulaR1C1 = "Amt"
With Detail.Columns("O:O")
.TextToColumns Destination:=Range("O1")
.NumberFormat = "#,##0"
End With
'.Progress 400

'Fix Equivalant (P)
Detail.Range("P1").FormulaR1C1 = "Equivalant"
With Detail.Columns("P:P")
.TextToColumns Destination:=Range("P1")
.NumberFormat = "#,##0"
End With
Detail.Columns("P:P").EntireColumn.Hidden = True

'Fix Ext-Cost (Q)
Detail.Range("Q1").FormulaR1C1 = "Ext-Cost"
With Detail.Columns("Q:Q")
.TextToColumns Destination:=Range("Q1")
.NumberFormat = "#,##0"
End With

'Fix Unit-Cost (R)
Detail.Range("R1").FormulaR1C1 = "Unit-Cost"
With Detail.Columns("R:R")
.TextToColumns Destination:=Range("R1")
.NumberFormat = "#,##0"
End With

'Fix Profit (S)
Detail.Range("S1").FormulaR1C1 = "Profit"
With Detail.Columns("S:S")
.TextToColumns Destination:=Range("S1")
.NumberFormat = "#,##0"
End With

'Add Percentage to End (T)
Detail.Range("T1").FormulaR1C1 = "%"
Detail.Range("T2:T" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).FormulaR1C1 = _
"=IF(RC[-5]=0,""No Sale"",RC[-1]/RC[-5])"
Detail.Range("T1:T" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value = _
Detail.Range("T1:T" & Detail.Cells(Detail.Rows.Count, 1).End(xlUp).Row).Value
Detail.Select
Range("T2").Select
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:="0"
With Selection.FormatConditions(1)
.Font.Bold = True
.Interior.ColorIndex = 44
End With
Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:="=""No Sale"""
With Selection.FormatConditions(2)
.Font.Bold = True
.Interior.ColorIndex = 6
End With
Selection.NumberFormat = "0.00%"
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
Selection.PasteSpecial Paste:=xlPasteFormats

'Close Atlanta Codes workbook and delete product and customer lists
If WasCodesOpen = False Then
Codes.Close
End If
Cust.Delete
Prod.Delete

'Set Print Heading
With Range("A1:T1")
.HorizontalAlignment = xlCenter
.Font.Bold = True
.Font.ColorIndex = 2
.Interior.ColorIndex = 1
End With
With ActiveSheet.PageSetup
.LeftHeader = "&""Arial,Bold""&12Atalanta"
.CenterHeader = "&""Arial,Bold""&14&A"
.RightHeader = "&""Arial,Bold""&12Sorted by"
.LeftFooter = "&""Arial,Bold""&D &T Dan Blois"
.CenterFooter = "&""Arial,Bold""&F"
.RightFooter = "&""Arial,Bold""Page &P of &N"
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.9)
.BottomMargin = Application.InchesToPoints(0.6)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintGridlines = True
.CenterHorizontally = True
.FitToPagesWide = 1
.PrintTitleRows = "$1:$1"
End With

'Sort By Customer Then Product Then Date
Detail.Range("A1", ActiveCell.SpecialCells(xlLastCell)).Sort Key1:=Range("E2"), Order1:=xlAscending, Key2:
= _
Range("I2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlDescending _
, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, _
DataOption3:=xlSortNormal

SummarySheets

'End Progress Bar
'.Progress 500
'.ProgressFinish
'End With
'Set spStatBar = Nothing

'Freeze Row 1
Detail.Range("A2").Select
ActiveWindow.FreezePanes = True
Beep
Beep

End Sub[/vba]

[lucas]

I can't be sure whats going on with your file without more info but attached is Justins code in an example workbook. I have commented where to put your code. Just replace the sleep code with your code...Hope this helps. If not I would suggest you post your code or workbook so someone can see whats going on with it.

[lucas]

Looks like you need to import the class file from justins post #4 above. Hope this helps

[lucas]

You should use line breaks before posting your code so it doesn't run off of the screen. space followed by an underline then enter

[Djblois]

Lucas,

I downloaded the class file but how do I import it into my code?

Daniel

[lucas]

Hi Daniel,
Easy, in the visual basic editor go to the project explorer on the top left and look for vba project(Book1) where book1 is the name of your workbook. Right click on it and select import file. Browse to it on your hard drive and click ok. It will be put in a folder similar to modules called class modules. Once it is there then your other routine can access it.

[lucas]

The file I uploaded in post 11 already has it imported.