Still Struggling with Progress Bar Logic

R

ryguy7272

I downloaded a sample of a very cool Progress Bar from this site:
http://www.enhanceddatasystems.com/ED/Pages/ExcelProgressBar.htm

I am trying to determine how to implement it with my code, but can’t seem to
figure it out. How does the Progress Bar figure out how long the entire
process will take? Can someone please take a look at this, and let me know
what I am doing wrong?

'clsProgBar
Public DisableCancel As Boolean
Public Title As String
Private nVersion As Integer
Private strStatus As String
Private strStat1 As String
Private strStat2 As String
Private strStat3 As String
Private strProgress As String
Property Let Caption1(strCaption As String)
If nVersion < 9 Then
strStat1 = strCaption
UpdateStatus
Else
#If VBA6 Then
frmProgress.lblMsg1.Caption = strCaption
DoEvents
#End If
End If
End Property
Property Let Caption2(strCaption As String)
If nVersion < 9 Then
strStat2 = strCaption
UpdateStatus
Else
#If VBA6 Then
frmProgress.lblMsg2.Caption = strCaption
DoEvents
#End If
End If
End Property
Property Let Caption3(strCaption As String)
If nVersion < 9 Then
strStat3 = strCaption
UpdateStatus
Else
#If VBA6 Then
frmProgress.lblMsg3.Caption = strCaption
DoEvents
#End If
End If
End Property
Sub Finish()

If nVersion < 9 Then
Application.StatusBar = ""
Application.StatusBar = False
Else
#If VBA6 Then
Unload frmProgress
#End If
End If
End Sub

Sub Hide()
If nVersion < 9 Then
Application.StatusBar = ""
Application.StatusBar = False
Else
#If VBA6 Then
frmProgress.Hide
#End If
End If
End Sub

Property Let Progress(nWidth As Integer)
Dim nProgress As Intege
If nVersion < 9 Then
strProgress = CStr(nWidth)
UpdateStatus
Else
#If VBA6 Then
If nWidth > 100 Then nWidth = 100
If nWidth < 0 Then nWidth = 0
With frmProgress.imgProgFore
.Width = 200 - Int(nWidth * 2)
.Left = 12 + Int(nWidth * 2)
End With
DoEvents
#End If
End I
End Property

Sub Reset()
If nVersion < 9 Then
Application.StatusBar = ""
Application.StatusBar = False
Else
#If VBA6 Then
Title = ""
frmProgress.lblMsg1.Caption = ""
frmProgress.lblMsg2.Caption = ""
frmProgress.lblMsg3.Caption = ""
DisableCancel = False
#End If
End If

End Sub

Sub Show()
If nVersion < 9 Then
'probably best to leave the title out of this

Else
#If VBA6 Then
With frmProgress
If DisableCancel = True Then
.Width = 228
.cmdCancel.Enabled = False
End If
.Caption = Title
.Show vbModeless
End With
#End If
End If

End Sub
Private Sub Class_Initialize()
nVersion = Val(Application.Version)
End Sub

Private Sub Class_Terminate()
If nVersion < 9 Then Application.StatusBar = False
End Sub

Private Sub UpdateStatus()
Dim strStatus As String
strStatus = strStat1
If strStat2 <> "" Then strStatus = strStatus & ", " & strStat2
If strStat3 <> "" Then strStatus = strStatus & ", " & strStat3
If strProgress <> "" Then strStatus = strStatus & ", " & strProgress & "%"
Application.StatusBar = strStatu
End Sub



'frmProgress
Private Sub cmdCancel_Click()
UserCancelled = True
End Sub
Private Sub UserForm_Initialize()
UserCancelled = False
End Sub



For my code to run, just enter consecutive numbers 1 to 82 in AA1:AA82, then
run the macro:
'mDemo Module
Sub ProgBarDemo()
Dim PB As clsProgBar
Dim nCounter As Integer
Dim lWaitCount As Long

Set PB = New clsProgBar

With PB
.Title = "Enhanced Datasystems Progress Bar"
.Show

For nCounter = 0 To 100

.Progress = nCounter
.Caption1 = "Progress message " & CStr(nCounter)
For lWaitCount = 0 To 1000000

‘My macro begins here:
Application.DisplayAlerts = False
Columns("A:Z").Select
Range("Z1").Activate
Selection.ClearContents
Application.DisplayAlerts = True

Range("A1").Activate

For Each c In Sheets("Import Sheet").Range("AA1:AA82")
lstRw = Cells(Rows.Count, 1).End(xlUp).Row

str1 = "URL;http://www.osha.gov/pls/imis/sic_manual.display?id=" &
c.Value & "&tab=group"
With ActiveSheet.QueryTables.Add(Connection:=str1 _
, Destination:=Range("A" & lstRw + 1))

'.Name = str1
.Name = "sic_manual.display?id=" & c.Value & "&tab=group"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "5"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next c

Columns("A:B").Select
Range("B1").Activate
Selection.Copy

Range("Y1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Sort Key1:=Range("Z1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Columns("A:B").Select
Selection.ClearContents


Range("X1").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[2],LEN(RC[2])-5)"
Range("X1").Select
Selection.AutoFill Destination:=Range("X1:X1004")
Range("X1:X1004").Select
Selection.Copy



Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select

If UserCancelled = True Then GoTo EndRoutine

Next lWaitCount

Next nCounter

EndRoutine:

.Finish

End With

Set PB = Nothing

End Sub


Cordially,
Ryan--
 
R

ryguy7272

Whoops! Sorry for the double-post. I got a message saying the first one
didn’t go through. Well, I guess it did!
--
RyGuy


ryguy7272 said:
I downloaded a sample of a very cool Progress Bar from this site:
http://www.enhanceddatasystems.com/ED/Pages/ExcelProgressBar.htm

I am trying to determine how to implement it with my code, but can’t seem to
figure it out. How does the Progress Bar figure out how long the entire
process will take? Can someone please take a look at this, and let me know
what I am doing wrong?

'clsProgBar
Public DisableCancel As Boolean
Public Title As String
Private nVersion As Integer
Private strStatus As String
Private strStat1 As String
Private strStat2 As String
Private strStat3 As String
Private strProgress As String
Property Let Caption1(strCaption As String)
If nVersion < 9 Then
strStat1 = strCaption
UpdateStatus
Else
#If VBA6 Then
frmProgress.lblMsg1.Caption = strCaption
DoEvents
#End If
End If
End Property
Property Let Caption2(strCaption As String)
If nVersion < 9 Then
strStat2 = strCaption
UpdateStatus
Else
#If VBA6 Then
frmProgress.lblMsg2.Caption = strCaption
DoEvents
#End If
End If
End Property
Property Let Caption3(strCaption As String)
If nVersion < 9 Then
strStat3 = strCaption
UpdateStatus
Else
#If VBA6 Then
frmProgress.lblMsg3.Caption = strCaption
DoEvents
#End If
End If
End Property
Sub Finish()

If nVersion < 9 Then
Application.StatusBar = ""
Application.StatusBar = False
Else
#If VBA6 Then
Unload frmProgress
#End If
End If
End Sub

Sub Hide()
If nVersion < 9 Then
Application.StatusBar = ""
Application.StatusBar = False
Else
#If VBA6 Then
frmProgress.Hide
#End If
End If
End Sub

Property Let Progress(nWidth As Integer)
Dim nProgress As Intege
If nVersion < 9 Then
strProgress = CStr(nWidth)
UpdateStatus
Else
#If VBA6 Then
If nWidth > 100 Then nWidth = 100
If nWidth < 0 Then nWidth = 0
With frmProgress.imgProgFore
.Width = 200 - Int(nWidth * 2)
.Left = 12 + Int(nWidth * 2)
End With
DoEvents
#End If
End I
End Property

Sub Reset()
If nVersion < 9 Then
Application.StatusBar = ""
Application.StatusBar = False
Else
#If VBA6 Then
Title = ""
frmProgress.lblMsg1.Caption = ""
frmProgress.lblMsg2.Caption = ""
frmProgress.lblMsg3.Caption = ""
DisableCancel = False
#End If
End If

End Sub

Sub Show()
If nVersion < 9 Then
'probably best to leave the title out of this

Else
#If VBA6 Then
With frmProgress
If DisableCancel = True Then
.Width = 228
.cmdCancel.Enabled = False
End If
.Caption = Title
.Show vbModeless
End With
#End If
End If

End Sub
Private Sub Class_Initialize()
nVersion = Val(Application.Version)
End Sub

Private Sub Class_Terminate()
If nVersion < 9 Then Application.StatusBar = False
End Sub

Private Sub UpdateStatus()
Dim strStatus As String
strStatus = strStat1
If strStat2 <> "" Then strStatus = strStatus & ", " & strStat2
If strStat3 <> "" Then strStatus = strStatus & ", " & strStat3
If strProgress <> "" Then strStatus = strStatus & ", " & strProgress & "%"
Application.StatusBar = strStatu
End Sub



'frmProgress
Private Sub cmdCancel_Click()
UserCancelled = True
End Sub
Private Sub UserForm_Initialize()
UserCancelled = False
End Sub



For my code to run, just enter consecutive numbers 1 to 82 in AA1:AA82, then
run the macro:
'mDemo Module
Sub ProgBarDemo()
Dim PB As clsProgBar
Dim nCounter As Integer
Dim lWaitCount As Long

Set PB = New clsProgBar

With PB
.Title = "Enhanced Datasystems Progress Bar"
.Show

For nCounter = 0 To 100

.Progress = nCounter
.Caption1 = "Progress message " & CStr(nCounter)
For lWaitCount = 0 To 1000000

‘My macro begins here:
Application.DisplayAlerts = False
Columns("A:Z").Select
Range("Z1").Activate
Selection.ClearContents
Application.DisplayAlerts = True

Range("A1").Activate

For Each c In Sheets("Import Sheet").Range("AA1:AA82")
lstRw = Cells(Rows.Count, 1).End(xlUp).Row

str1 = "URL;http://www.osha.gov/pls/imis/sic_manual.display?id=" &
c.Value & "&tab=group"
With ActiveSheet.QueryTables.Add(Connection:=str1 _
, Destination:=Range("A" & lstRw + 1))

'.Name = str1
.Name = "sic_manual.display?id=" & c.Value & "&tab=group"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "5"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next c

Columns("A:B").Select
Range("B1").Activate
Selection.Copy

Range("Y1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Sort Key1:=Range("Z1"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Columns("A:B").Select
Selection.ClearContents


Range("X1").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[2],LEN(RC[2])-5)"
Range("X1").Select
Selection.AutoFill Destination:=Range("X1:X1004")
Range("X1:X1004").Select
Selection.Copy



Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select

If UserCancelled = True Then GoTo EndRoutine

Next lWaitCount

Next nCounter

EndRoutine:

.Finish

End With

Set PB = Nothing

End Sub


Cordially,
Ryan--
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Making a macro only work on certain files 2
VBA Export to PDF 0
Remove Identical words 0
Still Struggling with Progress Bar Logic 4
VBA for Dependents shortcut menu 0
Macro converts time entered in column E and F from Indian time to CST( without daylight saving) 1
Progress Bar Internet Connection 0
how to have 2 drop down lists filter rows 2

Top