VBA Progress bar

[Rhemo]

Hi all,
I have a macro to email certain sheets to people, works fine no issues. I am attempting to make a progress bar for this macro, it runs for the first email then I get Object variable or With block variable not set, when i debug its highlight the .To=
For my testing I have used a static email address, but that should not cause that error. I'm posting my code below, please note I've changed the email domain to domain.com any insight or help would be greatly appreciated!

Sub EmailEachUser()
Dim ws As Worksheet
Call ClearClipboard
cws = 0
Dim i As Long, LastUser As Long
Dim pctdone As Single
Dim OutApp As Object
Dim OutMail As Object
Dim xInspect As Object
Dim pageEditor As Object
' Dim Ash As Worksheet
Dim xRg As Range
Dim CCmail As Worksheet
'Worksheets("Frontpage").Activate
Set CCmail = Worksheets("Frontpage")
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Frontpage" And ws.Name <> "MailInfo" And ws.Name <> "SLA" And ws.Name <> "All Aging Tickets" And ws.Name <> "High Sev Tickets" And ws.Name <> "OTTHQ" And ws.Name <> "ECDs" And ws.Name <> "Resolved Tickets" And ws.Name <> "Template" And ws.Name <> "ECDData" And ws.Name <> "ECDResults" And ws.Name <> "ECDCalcs" And ws.Name <> "OT_Hours" Then
ufProgress.LabelProgress.Width = 0
ufProgress.Show
    cws = cws + 1
    Else
        'Do nothing
    End If
Next
  
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> "Frontpage" And ws.Name <> "MailInfo" And ws.Name <> "SLA" And ws.Name <> "All Aging Tickets" And ws.Name <> "High Sev Tickets" And ws.Name <> "OTTHQ" And ws.Name <> "ECDs" And ws.Name <> "Resolved Tickets" And ws.Name <> "Template" And ws.Name <> "ECDData" And ws.Name <> "ECDResults" And ws.Name <> "ECDCalcs" And ws.Name <> "OT_Hours" Then
ufProgress.LabelProgress.Width = 0
ufProgress.Show
    For i = 1 To cws
        pctdone = i / cws
        With ufProgress
            .LabelCaption.Caption = "Processing user " & i & " of " & cws
            .LabelProgress.Width = pctdone * (.FrameProgress.Width)
        End With
        DoEvents
        ws.Activate
'        Set Ash = ws
       
        Application.ScreenUpdating = False
            For Each xRg In ws.Range("A7:F15")
            If xRg.Value = "" Then
                xRg.EntireRow.Hidden = True
            Else
                xRg.EntireRow.Hidden = False
            End If
            Next xRg
           
            For Each xRg In ws.Range("A21:F35")
            If xRg.Value = "" Then
                xRg.EntireRow.Hidden = True
            Else
                xRg.EntireRow.Hidden = False
            End If
            Next xRg
           
                For Each xRg In ws.Range("A41:H55")
            If xRg.Value = "" Then
                xRg.EntireRow.Hidden = True
            Else
                xRg.EntireRow.Hidden = False
            End If
            Next xRg
                   
                For Each xRg In ws.Range("A61:I80")
            If xRg.Value = "" Then
                xRg.EntireRow.Hidden = True
            Else
                xRg.EntireRow.Hidden = False
            End If
            Next xRg

        With OutMail
            .To = ws.Name & "@domain.com"
            .CC = CCmail.Range("M1").Text
            .BCC = ""
            .Subject = "Trouble Ticket Statistics " & ActiveWorkbook.Sheets("Frontpage").Range("I1").Value & " - " & ActiveWorkbook.Sheets("Frontpage").Range("J1").Value
            .Body = "Below are your trouble ticket statistics." & vbCrLf & "Kind Regards"
            .Display
            Set xInspect = OutMail.GetInspector
            Set pageEditor = xInspect.WordEditor
            ws.Range("A2:I80").Copy
            pageEditor.Application.Selection.Start = Len(.Body)
            pageEditor.Application.Selection.End = pageEditor.Application.Selection.Start
            pageEditor.Application.Selection.PasteAndFormat (wdFormatPlainText)
            .Send
            Set pageEditor = Nothing
            Set xInspect = Nothing
        End With
       
        Set OutMail = Nothing
        Set OutApp = Nothing
        'Set Ash = Nothing
        Rows.EntireRow.Hidden = False
        Application.Wait (Now + TimeValue("0:00:3"))
        If i = cws Then Unload ufProgress
        Next i
    End If
Next ws
Application.ScreenUpdating = False
End Sub

 

[nemmi69]

You can use the status bar at the bottom as a progress bar

Dim x               As Integer
Dim MyTimer         As Double

'Change this loop as needed.
For x = 1 To 50
    ' Do stuff
    Application.StatusBar = "Progress: " & x & " of 50: " & Format(x / 50, "0%")
Next x

Application.StatusBar = ""

 

[Rhemo]

You can use the status bar at the bottom as a progress bar

Dim x               As Integer
Dim MyTimer         As Double

'Change this loop as needed.
For x = 1 To 50
    ' Do stuff
    Application.StatusBar = "Progress: " & x & " of 50: " & Format(x / 50, "0%")
Next x

Application.StatusBar = ""

Thank Nemmi, yes I knew I could use the status bar, but I was hoping to use the userform one. Looks nicer and is a bit more noticeable

 

[nemmi69]

There is already a post on here about the user form one.

VBA - Creating a Progress Bar While Macro is Running

 

[Rhemo]

There is already a post on here about the user form one.

VBA - Creating a Progress Bar While Macro is Running

Thank you for that, i'll be reading that now.
I have the progress bar working, its displaying correctly and moving properly, the issue is when the macro moves to the second sheet to email VBA stops with "Object variable or With block variable not set" at the .TO= in the email section