Excel Progress Bar

[mackypogi]

Hi All,

I have a code that compares data using countif function, If I have too many data to calculate, my excel file will freeze that is why Id like to add a "Progress Bar" in my code. I already have one but only shows in Application.StatusBar.

Id like to have a form to show the progress,I found some sites with tutorial but does not fit with my code. I hope somebody could help me. Id like to have like this one. Progress Indicator in Excel VBA - Easy Excel Macros
Hope someone can relate my code to this site.

Here is my code

Sub Checker()
'
' Macro Checker
'
    Dim LastRow1 As Long
    Dim LastRow2 As Long
    Dim LastRow3 As Long
    Dim x As Integer
    Dim Str As String
    Dim pctCompl As Single
    
    Sheets("Checker").Visible = True
    
    '/// Builder
    Application.ScreenUpdating = False
    Sheets("Checker").Select
    Range("A2").Select
    ActiveCell.FormulaR1C1 = _
        "=CLEAN(TRIM(Builder!RC))&CLEAN(TRIM(Builder!RC[1]))&CLEAN(TRIM(Builder!RC[2]))&CLEAN(TRIM(Builder!RC[3]))&CLEAN(TRIM(Builder!RC[4]))&CLEAN(TRIM(Builder!RC[5]))&CLEAN(TRIM(Builder!RC[6]))&CLEAN(TRIM(Builder!RC[7]))&CLEAN(TRIM(Builder!RC[8]))&CLEAN(TRIM(Builder!RC[9]))"
    LastRow1 = Sheets("Builder").Cells(Rows.Count, "A").End(xlUp).Row
    LastRow1 = LastRow1 + 1
    On Error Resume Next
    Selection.AutoFill Destination:=Range("A2:A" & LastRow1)
    
    '/// SAP Export
    
    Sheets("Checker").Select
    Range("B2").Select
    ActiveCell.FormulaR1C1 = _
        "=TRIM('SAP Export'!RC[-1])&TRIM('SAP Export'!RC)&TRIM('SAP Export'!RC[1])&TRIM('SAP Export'!RC[2])&TRIM('SAP Export'!RC[3])&TRIM('SAP Export'!RC[4])&TRIM('SAP Export'!RC[5])&TRIM('SAP Export'!RC[6])&TRIM('SAP Export'!RC[7])&TRIM('SAP Export'!RC[8])"
    LastRow2 = Sheets("SAP Export").Cells(Rows.Count, "A").End(xlUp).Row
    LastRow2 = LastRow2 + 1
    On Error Resume Next
    Selection.AutoFill Destination:=Range("B2:B" & LastRow2)
    
    '/// Countif Checker
    
    
    Sheets("Checker").Select
    Range("C2").Select
    x = Sheets("Checker").Cells(Rows.Count, "A").End(xlUp).Row
    
    For Xloop = 2 To x
    Str = "=IF(COUNTIF($B$2:$B$" & x & ",A" & Xloop & ")>0,""OK"",""MISSING"")"
    'MsgBox Str
    Sheets("Checker").Range("C" & Xloop).Value = Str
    'Application.StatusBar = "Progress: " & Xloop & " of " & x & ": " & Format(Xloop / x, "0%") ' progressbar
    Next
    Application.StatusBar = False
    Sheets("Checker").Range("C2:C" & x).Copy
    Sheets("Builder").Select
    Range("K2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
    Sheets("Checker").Visible = False
    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub

Thank you!

 

[sijpie]

Implementing the progress bar is a good thing, but improving your code so that the user doesn't have to wait is a far better thing!

There are a number of operations you carry out in your loop which are very slow and more to the point, which can be replaced by very fast code.

Your loop:

    For Xloop = 2 To x
        Str = "=IF(COUNTIF($B$2:$B$" & x & ",A" & Xloop & ")>0,""OK"",""MISSING"")"
        Sheets("Checker").Range("C" & Xloop).Value = Str
    Next

You are filling a range of cells with a formula, one cell at a time. Read and particular write operations take a lot of time in Excel, so try to limit them.
Luckily you can write a formula to a range in one go, so no loop required! if it is a large number of rows, then it will still take some time, but a magnitude of seconds less.

So replace your For Xloop / next with:

        Sheets("Checker").Range("C2:C" & x).Formula = "=IF(COUNTIF($B$2:$B$" & x & ",A2)>0,""OK"",""MISSING"")"

So you see how even the A2, which looks hard coded in the above formula, changes to A3, A4 etc for the rows below. Neat or what?


later on you use range.copy & range.pastespecial to copy the values from one cell to another cell. this uses the Windows clipboard and so Excel has to wait for Windows to carry out this task
Blindingly fast is to tell the cell (or range) that it should take the same value as the other cell (or range)

Bad:

Sheets("Checker").Range("C2:C" & x).Copy
    Sheets("Builder").Select
    Range("K2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Good:

    Sheets("Builder").Range("K2":K" & x).value = Sheets("Checker").Range("C2:C" & x).value

let me know how you get on with this.

there are a few more improvements you can make, like don't select sheets or rnages, just do what you want without selecting. See my handy little guide on better coding, link in my tagline below.