Build a simple progress bar

S

SQUIDD

Well-known Member
Joined
Jan 2, 2009
Messages
2,104
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

Excel Wisdom
Using a mouse in Excel is the work equivalent of wearing a lanyard when you first get to college
Sort by date Sort by votes
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
That would be a good idea but i dont know how to do it.

Dave
 
Upvote 0
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
Would this work with the code I have posted above.I am not sure how to nest it in.Thankyou.

Dave
 
Upvote 0
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
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

K
  • Question
Scraping a table from a website, VBA code needs to be updated, running into issues
Replies
1
Views
328
Dan_W
D
A
  • Question
URL in cell used in VBA code to import web data
Replies
8
Views
1K
johnnyL
J
A
  • Question
Getting table from a link from a cell value
Replies
0
Views
418
adipat
A
A
  • Question
Table is not downloading to excel
Replies
0
Views
439
adipat
A
T
  • Question
Import Data from Google Sheet char(10) missing
Replies
0
Views
580
tendosai
T

Forum statistics

Threads
1,214,615
Messages
6,120,538
Members
448,970
Latest member
kennimack

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
Back
Top