Build a simple progress bar

S

SQUIDD

Well-known Member
Joined
Jan 2, 2009
Messages
2,096
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Hello everyone

I have a really long process that takes about 14 hours, i need to run this ? times.The problem is i have no idea how far it has got or how long it has left.I would like to disable screen refreshing and have a progress bar, only something simple to display the progress.
Thanks for help in advance.

Here is my code so far.

Dave

Code: 
Sub callmacro()
    Dim r As Range
    Dim n As Long
    n = 1
    Sheets("NUMBERS").Select
    Set r = Range("A1")
    While Not r.Value = ""
        Call Macro1(r, n)
        n = n + 1
        Sheets("NUMBERS").Select
        Set r = Range("A" & Trim(Str(n)))
    Wend
End Sub
Sub Macro1(r As Range, i As Long)
'
' Macro1 Macro
' everything
'
'
Sheets("RACE IMPORT").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.thedogs.co.uk/resultsRace.aspx?raceID=" & r.Value, Destination _
        :=Range("$A$1"))
        .Name = "resultsRace.aspx?raceID=220401-11"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = True
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
        End With
Sheets("TRAP 1").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.thedogs.co.uk/RaceCard.aspx?dogName=" & Range("24DOGS!$u$8").Value, Destination _
        :=Range("$A$1"))
        .Name = "RaceCard.aspx?dogName=Greylag Sam"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("b7:Z375").Select
    ActiveWorkbook.Worksheets("TRAP 1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRAP 1").Sort.SortFields.Add Key:=Range("Z9:Z156") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("TRAP 1").Sort
        .SetRange Range("b7:Z375")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("TRAP 2").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.thedogs.co.uk/RaceCard.aspx?dogName=" & Range("24DOGS!$u$9").Value, Destination _
        :=Range("$A$1"))
        .Name = "RaceCard.aspx?dogName=Greylag Sam"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("b7:Z156").Select
    ActiveWorkbook.Worksheets("TRAP 2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRAP 2").Sort.SortFields.Add Key:=Range("Z9:Z156") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("TRAP 2").Sort
        .SetRange Range("b7:Z156")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("TRAP 3").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.thedogs.co.uk/RaceCard.aspx?dogName=" & Range("24DOGS!$U$10").Value, Destination _
        :=Range("$A$1"))
        .Name = "RaceCard.aspx?dogName=Greylag Sam"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("b7:Z156").Select
    ActiveWorkbook.Worksheets("TRAP 3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRAP 3").Sort.SortFields.Add Key:=Range("Z9:Z156") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("TRAP 3").Sort
        .SetRange Range("b7:Z156")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("TRAP 4").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.thedogs.co.uk/RaceCard.aspx?dogName=" & Range("24DOGS!$U$11").Value, Destination _
        :=Range("$A$1"))
        .Name = "RaceCard.aspx?dogName=Greylag Sam"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("b7:Z156").Select
    ActiveWorkbook.Worksheets("TRAP 4").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRAP 4").Sort.SortFields.Add Key:=Range("Z9:Z156") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("TRAP 4").Sort
        .SetRange Range("b7:Z156")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("TRAP 5").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.thedogs.co.uk/RaceCard.aspx?dogName=" & Range("24DOGS!$U$12").Value, Destination _
        :=Range("$A$1"))
        .Name = "RaceCard.aspx?dogName=Greylag Sam"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("b7:Z156").Select
    ActiveWorkbook.Worksheets("TRAP 5").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRAP 5").Sort.SortFields.Add Key:=Range("Z9:Z156") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("TRAP 5").Sort
        .SetRange Range("b7:Z156")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Sheets("TRAP 6").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://www.thedogs.co.uk/RaceCard.aspx?dogName=" & Range("24DOGS!$U$13").Value, Destination _
        :=Range("$A$1"))
        .Name = "RaceCard.aspx?dogName=Greylag Sam"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlOverwriteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    Range("b7:Z156").Select
    ActiveWorkbook.Worksheets("TRAP 6").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("TRAP 6").Sort.SortFields.Add Key:=Range("Z9:Z156") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("TRAP 6").Sort
        .SetRange Range("b7:Z156")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        Sheets("Print Form").Select
    Range("A1:I39").Select
    Selection.Copy
    Sheets("data").Select
    Range("A" & Trim(Str(40 * (i - 1) + 1))).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Sheets("TRAP 1").Select
    Range("a1:v305").Select
    Selection.ClearContents
Sheets("TRAP 2").Select
    Range("a1:v305").Select
    Selection.ClearContents
Sheets("TRAP 3").Select
    Range("a1:v305").Select
    Selection.ClearContents
Sheets("TRAP 4").Select
    Range("a1:v305").Select
    Selection.ClearContents
Sheets("TRAP 5").Select
    Range("a1:v305").Select
    Selection.ClearContents
Sheets("TRAP 6").Select
    Range("a1:v305").Select
    Selection.ClearContents
    Sheets("RACE IMPORT").Select
    Range("a1:u100").Select
    Selection.ClearContents
    End With
    End Sub
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.
Sort by date Sort by votes
Jaafar Tribak

Jaafar Tribak

Well-known Member
Joined
Dec 5, 2002
Messages
9,245
Office Version
  1. 2016
Platform
  1. Windows
Hi,

The code is too long to read & see where it is best to place the "progress bar".

Have you thought about using the StatusBar to display the progress of the process?

Regards.
 
Upvote 0
S

SQUIDD

Well-known Member
Joined
Jan 2, 2009
Messages
2,096
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
That would be a good idea but i dont know how to do it.

Dave
 
Upvote 0
Stormseed

Stormseed

Banned
Joined
Sep 18, 2006
Messages
3,274
Hi

You can use this:
Code: 
Sub ntest()
With Application
.DisplayStatusBar = True
.StatusBar = "Work in Progress"
'your code here
.Wait Now + TimeValue("00:00:30")
'use this line incase you want to give the control of statusbar back to your programme.
.DisplayStatusBar = False
End With
End Sub
 
Upvote 0
S

SQUIDD

Well-known Member
Joined
Jan 2, 2009
Messages
2,096
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
ADVERTISEMENT
Would this work with the code I have posted above.I am not sure how to nest it in.Thankyou.

Dave
 
Upvote 0
Stormseed

Stormseed

Banned
Joined
Sep 18, 2006
Messages
3,274
How am I supposed to know at what particular stage in your macro code you want to see a progress bar and upto your time limit ?

Ofcourse, the code will work and I have also put a comment in my code to show you that you can insert a part of your code. My comment reads as " 'your code here ". It depends upon your decision about where exactly you want the progress bar to show the progress of your macro. If you want the progress bar to be displayed for the whole of your macro then you will have encapsulate all of your code within the line 'your code here.

I hope it is clear to you !
 
Upvote 0
S

SQUIDD

Well-known Member
Joined
Jan 2, 2009
Messages
2,096
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Thankyou everyone for your help.

I will try this when I get home tonight.

Dave
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Macro Button
Replies
1
Views
286
offthelip
O
A
  • Solved
Do While Loop Is Stuck
Replies
2
Views
534
ajax1231
A
A
  • Solved
URL link is not fully loaded when pulled, cant get loop to work
Replies
1
Views
564
ajax1231
A
S
  • Question
VBA webquery works in Excel 2010 but does not work in 2019
Replies
0
Views
401
sprivatester
S
D
  • Question
Inserting a Wait / Pause in a VBA loop to get around page request limit
Replies
4
Views
1K
Dan_W
D

Forum statistics

Threads
1,195,712
Messages
6,011,264
Members
441,598
Latest member
chrispaulpearce

Share this page

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
Top