Progress Meter

[jmersing]

I ahve some code that runs for about 5 minutes. I have cell displying the process in a percentage format. Does anyone know of a progress meter that I might be able to replace the percentage cell with?

Thanks

 

[Nimrod]

jmersing
Replace your code with this and see if it goes faster ??

Sub Main()
Application.Calculation = xlManual
Application.ScreenUpdating = False

With Range("A1:Y100")
.Formula = "=RAND()"
.Value = .Value
End With

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub




oopss forgot to make whole numbers to 1000

Sub Main()

Application.Calculation = xlManual
Application.ScreenUpdating = False
' Initialize variables.

With Range("A1:Y100")
.Formula = "=Int(RAND()* 1000)"
.Value = .Value
End With

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

 

[jmersing]

I almost have it, I have the form displaying now and it shows the percentage complete based on two cells in my Sub that are calulating the percentage of the code that is complete. The only problem now is, its not updating? I must be missing something that tells it to update?? The two cells are updating I have the screen updating on.

Sub ShowUserForm()
frmWait.Show
End Sub

Sub UpdateProgressBar(PctDone As Single)
With frmWait

.FrameProgress.Caption = Format(PctDone, "0%")
(.FrameProgress.Width - 9)

End With
DoEvents
End Sub

Dim counter As Integer
Dim RowMax As Integer, ColMax As Integer
Dim r As Integer, c As Integer
Dim PctDone As Single
Dim need As Integer

counter = 1
RowMax = Range("B5").Value
ColMax = Range("B6").Value

PctDone = counter * (ColMax / RowMax)

UpdateProgressBar PctDone

skillx = 9
timeStart = -1
timeStart2 = 1
For period = 1 To 12
timeStart2 = timeStart2 + 6
timeStart = timeStart + 8
For skilly = 104 To 124
skillNam = Sheet236.Cells(skillx, skilly).Value
need = Sheet236.Cells(period + 318, skilly - 97).Value - Sheet236.Cells(period + 304, skilly - 97).Value
If skillNam = "ENG" Then
Eng period, timeStart2, skilly, need ' Eng period, timeStart, skilly, need
ElseIf skillNam = "IND" Then
Ind period, timeStart, skilly, need
Else
OtherSkill period, timeStart, skilly, skillNam, need
End If

Next skilly
Next period
Application.ScreenUpdating = True
End Sub


Thanks for your help

 

[Nimrod]

If you make your code faster you don't need the progress bar ... have you given this code a try ?? :wink:

Sub Main()
Application.Calculation = xlManual
Application.ScreenUpdating = False

With Range("A1:Y100")
.Formula = "=Int(RAND()* 1000)"
.Value = .Value
End With

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

 

[jmersing]

Yes I pasted that in , it just generated a bunch of random numbers?

I want the form to reflect what is going on in my Sub Main. The code will fill in about 3000 cells before it finishes. I'm expecting a wait, I'd just like to get the form working.

Thanks again

 

[Joe Was]

I use this:

Private Sub UserForm_Activate()
'User Form Code Module.
'You must make a userform with a progressBar on it!
'Note the progressbar is on "More Controls" [Right Click ToolBox].
Dim MyStart, MyDelay, MyFinish, CompletePct, MyCodeEndTest

'Sample code Defines.
Dim n As Integer
Dim MyCell As String
'Sample code Defines.

On Error GoTo MyEnd
MyCodeEndTest = False
n = 0
'Note: Timer in 100ths of a second.
MyStart = Timer
MyDelay = 5
MyFinish = MyStart + MyDelay
Do Until Timer > MyFinish

'This is part of the sample test code, you may not need this!
For a = 1 To 150000
'This is part of the sample test code, you may not need this!

CompletePct = (MyFinish - Timer) / MyDelay
Application.ScreenUpdating = True
UserForm1.ProgressBar1.Value = 100 - (CompletePct * 100)

'Your code to run with a "ProgressBar" go's here!
'This is sample test code only!
Application.ScreenUpdating = False
n = n + 1
MyCell = "A" & n
Sheets("Sheet1").Select
Sheets("Sheet1").Range(MyCell).Select
Application.ScreenUpdating = True
Selection.Value = "Test"
Application.ScreenUpdating = False
Next a
'This is sample test code only!

'End your code with a "Done" test: MyCodeEndTest = True
MyCodeEndTest = True
If MyCodeEndTest = True Then GoTo MyEnd
Loop
MyEnd:
Unload UserForm1

'This is optional code!
Application.ScreenUpdating = True
MsgBox "Done!"
Sheets("Sheet1").Range("A:A").Value = ""
Sheets("Sheet1").Range("A1").Select
'This is optional code!

End Sub

 

[Nimrod]

Sorry , I had asked for your code that was taking so long and I thought that is what you had given me.
I really think that speeding up the code, instead of telling the user it's going to take awhile, is the better way to go.
I would like to see you code that takes 2 minutes to run ...

However if that's not possible might I suggest you turn off sheet calculation while the code is running ... this may have a dramatic effect

eg

Sub Main()
Application.Calculation = xlManual
Application.ScreenUpdating = False

' YOUR SLOW CODE GOES HERE :wink:


Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
End Sub

 

[jmersing]

The code that I posted was the code that takes two minutes. The reason it takes so long is because it is referenecing cells that are formula driven and are being calculated as the code is running. I even have an array based formula that is doing quite alot all while the code is trying to run.
Changing the calculation to manual made a big difference. It's probably less than 30 seconds now.

Any thoughts on how to get the progress meter updating based o n the code in my previous post?

I have not had a chane to look at "Joe Was" post yet.

Thanks to both of you.

 

[Nimrod]

Hello jmersing

I'm really more interested in getting your code down to a point that you don't need a progress bar ... if you are that is .. :wink:

If interested in making the code faster please paste the code without the progress bar code . When I look at your previous posting I thougt I had found the code that was required but I was mistaken.



I'VE RUN THIS CODE IN NO TIME ???

'Here is my Sub
Sub Tasks()
Dim need As Integer
'Application.ScreenUpdating = False
skillx = 9
timeStart = -1
timeStart2 = 1

With Sheets("Sheet1")

For Period = 1 To 12
timeStart2 = timeStart2 + 6
timeStart = timeStart + 8


For skilly = 104 To 124
skillNam = .Cells(skillx, skilly).Value
need = .Cells(Period + 318, skilly - 97).Value - .Cells(Period + 304, skilly - 97).Value

If skillNam = "ENG" Then
'Eng Period, timeStart2, skilly, need ' Eng period, timeStart, skilly, need
ElseIf skillNam = "IND" Then
'Ind Period, timeStart, skilly, need
Else
' OtherSkill Period, timeStart, skilly, skillNam, need
End If

Next skilly
Next Period

End With
Application.ScreenUpdating = True
End Sub

COULD YOU Paste the code that it calls ie. Eng , Ind, Otherskill ???

 

[jmersing]

Sure I'd be glad to here is the whole thing.

Sub Button14_Click()

Dim need As Integer

Application.Calculation = xlManual

skillx = 9
timeStart = -1
For period = 1 To 12
timeStart = timeStart + 8
For skilly = 104 To 124
skillNam = Sheet236.Cells(skillx, skilly).Value
need = (Sheet236.Cells(period + 318, skilly - 97).Value - Sheet236.Cells(period + 304, skilly - 97).Value) * 4
If skillNam = "ENG" Then
Eng period, timeStart, skilly, need
ElseIf skillNam = "IND" Then
Ind period, timeStart, skilly, need
ElseIf skillNam = "MMS" Then
MMS period, timeStart, skilly, need
Else
OtherSkill period, timeStart, skilly, skillNam, need
End If
Next skilly
Next period
Application.ScreenUpdating = True
MsgBox "Finished"
Calculate
End Sub
Public Sub Eng(ByVal period As Integer, ByVal timeStart As Integer, ByVal skilly As Integer, ByVal need As Integer)
Dim counter As Integer
Dim did As Boolean
Dim n As Integer

With Sheet236
For x = 11 To 298
counter = 0
did = False
For n = 1 To timeStart
If .Cells(x, n).Value = "ENG" Then
did = True
End If
Next n
If .Cells(x, skilly).Value = "x" And did = False Then
For y = timeStart To timeStart + 7


'If Application.CountIf(.Cells(x, y) _
' .Offset(0, 1).Resize(1, 8), ".") = 8 _
'And .Cells(x, y).Value = "." _
'And counter < 1 _
'And need > 0 Then
'.Cells(x, y).Value = "ENG"
If WorksheetFunction.CountIf(.Cells(x, y).Resize(1, 8), ".") = 8 _
And counter < 8 _
And need > 0 Then _
.Cells(x, y).Value = "ENG"
'Cells(x, y).Resize(1, 8).Value = "ENG"


counter = counter + 1
need = need - 1


Next y
End If
Next x
End With
End Sub
Public Sub Ind(ByVal period As Integer, ByVal timeStart As Integer, ByVal skilly As Integer, ByVal need As Integer)
Dim counter As Integer
Dim did As Boolean
Dim n As Integer
With Sheet236
For x = 11 To 298
counter = 0
did = False
For n = 1 To timeStart
If .Cells(x, n).Value = "IND" Then
did = True
End If
Next n
If .Cells(x, skilly).Value = "x" And did = False Then
For y = timeStart To timeStart + 7
If .Cells(x, y).Value = "." _
And counter < 8 _
And need > 0 Then
.Cells(x, y).Value = "IND"
counter = counter + 1
need = need - 1
End If
Next y
End If
Next x
End With
End Sub
Public Sub OtherSkill(ByVal period As Integer, ByVal timeStart As Integer, ByVal skilly As Integer, ByVal skillNam As String, ByVal need As Integer)
With Sheet236
For x = 11 To 298
If .Cells(x, skilly).Value = "x" Then
For y = timeStart To timeStart + 7
If .Cells(x, y).Value = "." _
And need > 0 Then
.Cells(x, y).Value = skillNam
need = need - 1
End If
Next y
End If
Next x
End With
End Sub

Public Sub MMS(ByVal period As Integer, ByVal timeStart As Integer, ByVal skilly As Integer, ByVal need As Integer)
Dim counter As Integer
Dim did As Boolean
Dim n As Integer
With Sheet236
For x = 11 To 298
counter = 0
did = False
For n = 1 To timeStart
If .Cells(x, n).Value = "MMS" Then
did = True
End If
Next n
If .Cells(x, skilly).Value = "x" And did = False Then
For y = timeStart To timeStart + 7
If .Cells(x, y).Value = "." _
And .Cells(x + 4, y).Value = "." _
And counter > 8 _
And need > 0 Then
.Cells(x, y).Value = "MMS"
counter = counter + 1
need = need - 1
End If
Next y
End If
Next x
End With
End Sub



I am having a problem with one part of it though, and I'm not sure if you will get a full understanding of what I am trying to do, so I'll e-mail you a zip of the file if you provide your address.

The problem I'm having is that there are two codes must be in 8 cells at a time, no other combination. Other tasks have the ability to be replaced with the next code in priority order. But "ENG" and "Ind" can only be for 8 cells horizontally or just add "." and move on to the next row. Both ENG and IND can be repeated in an 8 hours shift. All of the other codes can, oh I almost forgot. MMS can only be 8 hours (34) cells at a time.

Thanks for taking the time to look at this for me. I'll ditch the progress meter, if we can get this thing working.