📌 What is a VBA Progress Bar?

A progress bar is a visual control (usually in a UserForm) that updates as your code executes. It doesn’t speed up the macro—it just informs users about progress.

📌 When to Use

Long-running loops (e.g., processing thousands of rows).

Multi-step workflows (e.g., Excel → Word → Outlook automation).

End-to-end processes where you want to reassure users.

📌 How It Works

UserForm with a Label or Frame → acts as the bar.

Macro updates width/percentage as tasks complete.

DoEvents ensures Excel updates the form while code runs.

Close the form once the macro finishes.

📌 Best Practices

Keep it lightweight – don’t add heavy graphics that slow VBA further.

Update occasionally – updating on every loop iteration can slow things down; update every 50/100 rows instead.

Give context – label the current step (e.g., “Exporting to Word…”).

Fail gracefully – ensure the bar closes even if an error occurs.

📌 Simple Example (Downloadable Sample Possible)

Insert a UserForm named frmProgress.

Add a Label named lblBar (the bar itself).

Add a Label named lblText (status message).

VBA Code:

'=== Standard Module ===

Sub RunWithProgressBar()

Dim i As Long, n As Long

n = 1000

' Show progress bar

frmProgress.Show vbModeless

frmProgress.lblBar.Width = 0

For i = 1 To n

' Simulate work

DoEvents

Application.Wait Now + TimeValue("0:00:01")

' Update progress bar every 50 iterations

If i Mod 50 = 0 Then

UpdateProgress i, n, "Processing row " & i

End If

Next i

' Done

Unload frmProgress

MsgBox "All tasks completed!", vbInformation

End Sub

'=== UserForm Module ===

Sub UpdateProgress(ByVal i As Long, ByVal n As Long, Optional ByVal msg As String)

With frmProgress

.lblBar.Width = (.InsideWidth - 20) * (i / n)

.lblText.Caption = Format(i / n, "0%") & " - " & msg

.Repaint

End With

End Sub

1. Open VBE: Alt+F11

2. Project Explorer: press Ctrl+R

3. Under your VBAProject, find the Forms section (you’ll see a form icon).

   • Double-click frmProgress (if your form is still called UserForm1, rename its (Name) to frmProgress first).

   • The code window title must say “Code – frmProgress”.

4. In that frmProgress code window, paste this (replace anything you had before):

Option Explicit

Private Sub UserForm_Initialize()
    lblBar.Width = 0
    lblText.Caption = "0% - Starting..."
End Sub

Public Sub UpdateProgress(ByVal i As Long, ByVal total As Long, Optional ByVal msg As String)
    Dim pct As Double

    If total < 1 Then total = 1
    pct = i / total

    If pct < 0 Then
        pct = 0
    ElseIf pct > 1 Then
        pct = 1
    End If

    ' use Me ONLY inside the form's code-behind
    Me.lblBar.Width = (Me.InsideWidth - 20) * pct
    Me.lblText.Caption = Format(pct, "0%") & IIf(Len(msg) > 0, " - " & msg, "")
    Me.Repaint
    DoEvents
End Sub

5. Very important: remove any copy of UpdateProgress you might have pasted into Module1/standard modules. There should be no Me in standard modules.

6. Compile: menu Debug → Compile VBAProject. If it compiles, you’re good.

Call it from your macro

At the start of your macro:

frmProgress.Show vbModeless
frmProgress.UpdateProgress 0, 1, "Preparing..."

Update during your outer loop:

frmProgress.UpdateProgress x, totalSteps, "Category: " & CStr(vCategory(x))

Always close (success or error):

Unload frmProgress

However, practical best practice limits filtering to 5–10 columns for performance and clarity. Here's why:

✅ What VBA Can Do

• Filter any number of columns using .AutoFilter Field:=n

• Apply different criteria per column

• Combine filters across columns using AND logic (default behavior)

• Use <>, >, <, =*, wildcards, and date ranges

🚫 What VBA Cannot Do Directly

• Apply OR logic across columns (e.g., show rows where Col1 = "X" OR Col2 = "Y")—requires helper columns or manual row hiding

• Filter non-contiguous columns unless you define a custom range

• Filter by color, icon, or formula result without extra logic

🧠 Best Practice Summary

TipWhy It MattersLimit to 5–10 columnsKeeps macros fast and readableUse named ranges or tablesEasier to maintainUse helper columns for complex logicEnables OR filters or multi-condition checksAvoid filtering every columnSlows down UI and increases risk of errors

Sub Filter_ByRegion()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("SalesTbl") ' Adjust if sheet name differs

    With ws
        .AutoFilterMode = False ' Clear previous filters
        .Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:="North" ' Field 2 = Region column
    End With
End Sub

region - single column multiple values

Sub Filter_Region_MultipleValues()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Data") ' Adjust if sheet name differs

    With ws
        .AutoFilterMode = False
        .Range("A1").CurrentRegion.AutoFilter _
            Field:=3, _
            Criteria1:=Array("North", "South", "East"), _
            Operator:=xlFilterValues
    End With
End Sub

multiple regions and multiple values

Sub Filter_RegionAndCountry()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("data") ' Adjust if sheet name differs

    With ws
        .AutoFilterMode = False
        .Range("A1").CurrentRegion.AutoFilter _
            Field:=3, _
            Criteria1:=Array("North", "South", "East"), _
            Operator:=xlFilterValues

        .Range("A1").CurrentRegion.AutoFilter _
            Field:=4, _
            Criteria1:=Array("Brunei", "Malaysia", "Singapore", "Thailand", "Vietnam"), _
            Operator:=xlFilterValues
    End With
End Sub

filter excluding selected values

Sub Setup_ExcludeHelper()
    Dim ws As Worksheet
    Dim excludeList As Variant
    Dim lastRow As Long, i As Long

    Set ws = ThisWorkbook.Sheets("Data")
    excludeList = Split(ws.Parent.Sheets("inputform").Range("F5").Text, ",")
    lastRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row

    ws.Range("u1").Value = "IncludeFlag"

    For i = 2 To lastRow
        If IsError(Application.Match(ws.Cells(i, 3).Value, excludeList, 0)) Then
            ws.Cells(i, 21).Value = "TRUE"
        Else
            ws.Cells(i, 21).Value = "FALSE"
        End If
    Next i
    
    ' Apply filter on helper column (assumed to be column 26 = Z)
    ws.Range("A1").CurrentRegion.AutoFilter _
        Field:=21, _
        Criteria1:="TRUE"
End Sub

data cleansing by Gemini

Sub CleanAndFormatDateColumn()

' 1. Setup Variables

Dim ws As Worksheet

Dim lastRow As Long

Dim cell As Range

Dim dateValue As Variant

' Set the worksheet (Modify "Sheet1" to your actual sheet name)

Set ws = ActiveSheet

' Determine the last row with data in Column A

' Assumes data starts in row 2

lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' 2. Loop Through Column A (Starting from A2 to skip header)

For Each cell In ws.Range("A2:A" & lastRow)

' Reset error handling for this loop iteration

On Error GoTo 0

' Try to convert the cell value to a date

On Error Resume Next

dateValue = CDate(cell.Value)

On Error GoTo 0 ' Turn off error handling immediately after the CDate attempt

' 3. Process the Result

If IsDate(dateValue) Then

' Conversion successful:

' a. Write the clean date back to the cell (removes any time component)

cell.Value = Int(dateValue)

' b. Format the cell as a consistent date format

cell.NumberFormat = "yyyy-mm-dd" ' A clear, universal format

Else

' Conversion failed (e.g., "invalid text"):

' You can leave the original text or mark it.

cell.Interior.Color = RGB(255, 255, 153) ' Highlight in yellow for manual review

cell.NumberFormat = "@" ' Ensure it's treated as text

End If

Next cell

' Final message

MsgBox "Date column cleaning complete! Cells that could not be converted are highlighted in yellow.", vbInformation

End Sub

Dim url As String

Dim xhr As Object, dom As Object

Dim ws As Worksheet

Dim dateNode As Object, rateNode As Object

Dim r As Long

url = "https://www.ecb.europa.eu/stats/eurofxref/eurofxref-daily.xml"

Sheets.Add after:=Sheets(Sheets.Count)

Set ws = ActiveSheet

ws.Cells.Clear

' Download XML

Set xhr = CreateObject("MSXML2.XMLHTTP")

xhr.Open "GET", url, False

xhr.send

If xhr.Status <> 200 Then

MsgBox "HTTP error: " & xhr.Status & " - " & xhr.statusText, vbExclamation

Exit Sub

End If

' Load into XML DOM

Set dom = CreateObject("MSXML2.DOMDocument.6.0")

dom.async = False

dom.validateOnParse = False

If Not dom.LoadXML(xhr.responseText) Then

MsgBox "XML parse error: " & dom.parseError.Reason, vbExclamation

Exit Sub

End If

' --- IMPORTANT: namespaces ---

' default namespace for <Cube> is ECB eurofxref ns; we must bind a prefix (ecb)

dom.setProperty "SelectionLanguage", "XPath"

dom.setProperty "SelectionNamespaces", _

"xmlns:ges='http://www.gesmes.org/xml/2002-08-01' " & _

"xmlns:ecb='http://www.ecb.int/vocabulary/2002-08-01/eurofxref'"

' Find the dated Cube and iterate its child rates

Set dateNode = dom.selectSingleNode("//ecb:Cube/ecb:Cube[@time]")

If dateNode Is Nothing Then

ws.Range("A1").Value = "Could not find dated node. Dumping first 500 chars for debugging:"

ws.Range("A2").Value = Left$(xhr.responseText, 500)

MsgBox "Could not find the <Cube time='...'> node (namespace issue solved in code; if you still see this, check the dump on the sheet).", vbExclamation

Exit Sub

End If

ws.Range("A1:C1").Value = Array("Date", "Currency", "Rate")

r = 2

For Each rateNode In dateNode.selectNodes("ecb:Cube[@currency]")

ws.Cells(r, 1).Value = dateNode.getAttribute("time")

ws.Cells(r, 2).Value = rateNode.getAttribute("currency")

ws.Cells(r, 3).Value = CDbl(rateNode.getAttribute("rate"))

r = r + 1

Next rateNode

' Add EUR = 1.0 (base)

ws.Cells(r, 1).Value = dateNode.getAttribute("time")

ws.Cells(r, 2).Value = "EUR"

ws.Cells(r, 3).Value = 1#

ws.Columns("A:C").AutoFit

ws.Rows(1).Font.Bold = True

MsgBox "Exchange rates retrieved: " & (r - 2) & " currencies.", vbInformation

End Sub

retrieve from local folder

Option Explicit

Public Sub Scrape_ProductsHtml()

Dim f As Variant, htmlText As String

Dim doc As Object ' HTMLDocument (late bound)

Dim ws As Worksheet, r As Long, c As Long

Dim tbls As Object, t As Object, row As Object, cell As Object

Dim items As Object, it As Object

'---- pick the local HTML file (defaults to products.html) ----

f = Application.GetOpenFilename("HTML Files (*.htm;*.html),*.htm;*.html", , _

"Select products.html", , False)

If VarType(f) = vbBoolean Then Exit Sub ' user cancelled

htmlText = ReadAllText(CStr(f))

If Len(htmlText) = 0 Then

MsgBox "File is empty or unreadable.", vbExclamation

Exit Sub

End If

'---- load into an HTML parser ----

Set doc = CreateObject("htmlfile")

doc.Open

doc.Write htmlText

doc.Close

'---- new output sheet ----

Sheets.Add after:=Sheets(Sheets.Count)

Set ws = ActiveSheet

ws.Cells.Clear

r = 1

'========== MODE A: dump all HTML tables ==========

Set tbls = doc.getElementsByTagName("table")

If Not tbls Is Nothing And tbls.Length > 0 Then

Dim tIdx As Long: tIdx = 1

For Each t In tbls

If r > 1 Then r = r + 2

ws.Cells(r, 1).Value = "Table " & tIdx

ws.Cells(r, 1).Font.Bold = True

r = r + 1

For Each row In t.getElementsByTagName("tr")

c = 1

For Each cell In row.Children ' td/th

ws.Cells(r, c).Value = CleanText(cell.innerText)

c = c + 1

Next cell

r = r + 1

Next row

tIdx = tIdx + 1

Next t

ws.Columns.AutoFit

MsgBox "Scraped " & tbls.Length & " table(s) from HTML.", vbInformation

Exit Sub

End If

'========== MODE B: ".product" cards/list ==========

' Adjust the selectors to match your markup

On Error Resume Next

Set items = doc.querySelectorAll(".product")

On Error GoTo 0

If Not items Is Nothing And items.Length > 0 Then

' headers

ws.Range("A1:C1").Value = Array("Name", "Price", "SKU")

r = 2

For Each it In items

ws.Cells(r, 1).Value = CleanText(QText(it, ".name"))

ws.Cells(r, 2).Value = CleanText(QText(it, ".price"))

ws.Cells(r, 3).Value = AttrOf(it, "data-sku")

r = r + 1

Next it

ws.Columns("A:C").AutoFit

ws.Rows(1).Font.Bold = True

MsgBox "Scraped " & items.Length & " product card(s).", vbInformation

Exit Sub

End If

' If neither layout found, drop a hint

ws.Range("A1").Value = "No <table> or .product items found."

ws.Range("A2").Value = "Tip: change the CSS selectors in MODE B to match your HTML."

MsgBox "Nothing matched. Check selectors or HTML structure.", vbExclamation

End Sub

'----------------- helpers -----------------

Private Function ReadAllText(ByVal path As String) As String

Dim ff As Integer: ff = FreeFile

On Error GoTo Fail

Open path For Binary As #ff

ReadAllText = Space$(LOF(ff))

Get #ff, , ReadAllText

Close #ff

Exit Function

Fail:

On Error Resume Next

If ff <> 0 Then Close #ff

End Function

' Returns innerText of first match for CSS selector under node (or "")

Private Function QText(ByVal node As Object, ByVal css As String) As String

Dim el As Object

On Error Resume Next

Set el = node.querySelector(css)

On Error GoTo 0

If Not el Is Nothing Then QText = el.innerText

End Function

' Returns attribute value (or "")

Private Function AttrOf(ByVal node As Object, ByVal name As String) As String

On Error Resume Next

AttrOf = node.getAttribute(name)

On Error GoTo 0

End Function

' Trim and collapse whitespace/newlines

Private Function CleanText(ByVal s As String) As String

Dim t As String

t = Trim$(s)

t = Replace(t, vbCr, " ")

t = Replace(t, vbLf, " ")

Do While InStr(t, " ") > 0

t = Replace(t, " ", " ")

Loop

CleanText = t

End Function

Dim http As Object

Dim html As Object

Dim tbl As Object

Dim row As Object, cell As Object

Dim i As Long, j As Long

Dim wks As Worksheet

Set wks = ThisWorkbook.Sheets("ExchangeRates")

' Create HTTP and HTML objects

Set http = CreateObject("MSXML2.XMLHTTP")

Set html = CreateObject("htmlfile")

' Fetch the ECB exchange rates page

http.Open "GET", "https://www.ecb.europa.eu/stats/policy_and_exchange_rates/euro_reference_exchange_rates/html/index.en.html", False

http.send

' Load the HTML content

html.body.innerHTML = http.responseText

' Find the exchange rate table

Set tbl = html.getElementsByTagName("table")(0) ' First table on the page

' Output to Excel starting at cell A1

i = 1

For Each row In tbl.getElementsByTagName("tr")

j = 1

For Each cell In row.getElementsByTagName("td")

wks.Cells(i, j).Value = cell.innerText

j = j + 1

Next cell

i = i + 1

Next row

MsgBox "Exchange rates imported successfully!", vbInformation

End Sub