I have been messing with a userform progressbar for quiet some time now and checked all references and threads possible and can not seem to find a solution that will work for me.
My code takes approximately 3 minutes or so to run and wanted to setup a progressbar to indicate what is happening so users dont feel like it crashed or froze on them.
I have previously used the statusbar change option which many users neglected, so I was hoping for an alternative.
Below is the code running
And here is the code I am trying to manipulate to run through my loops to show progress while keeping the % running.
Any help or suggestions would be greatly appreciated as I have all but given up hope ... fortunately the application.wait now + timevalue lines must remain, even though they slow down the code quite a bit as the sendkeys pagesetup code will fail without any delays in place.
My code takes approximately 3 minutes or so to run and wanted to setup a progressbar to indicate what is happening so users dont feel like it crashed or froze on them.
I have previously used the statusbar change option which many users neglected, so I was hoping for an alternative.
Below is the code running
Code:
Sub UpdateMAPs()
Dim LR As Long
Dim i As Long
Dim r As Integer
Dim sh As Worksheet
Dim shCount As Integer
Dim AltKey As String
Dim TabKey As String
Dim EnterKey As String
'--------------------------
AltKey = "%"
TabKey = "{TAB}"
EnterKey = "~"
shCount = Application.Sheets.Count
'--------------------------
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'--------------------------
'Check for existing MAPs and delete them
If shCount > 11 Then
For Each sh In ThisWorkbook.Sheets '
Select Case sh.Name
Case "Team List", "Targets", "Call Data", "Quality", "SQM", "SmartLink", "ICV", "2nd Lines", "Credits per Call", "ARC", "Blank MAP"
'Do nothing
Case Else
sh.Delete
End Select
Next sh
Else
End If
'--------------------------
Application.DisplayAlerts = True
'--------------------------
'Create MAPs from team list and add agent name, emp id, avaya and coaches name
Sheets(1).Select
Range("D2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Sort Key1:=Range("D2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
With Sheets(1)
LR = .Range("D" & Rows.Count).End(xlUp).Row
For i = 3 To LR
Sheets(11).Activate
Range("$A$1:$W$63").Select
Selection.Copy
Sheets(11).Select
Sheets.Add
ActiveSheet.Name = .Range("D" & i).Value
ActiveSheet.Paste
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Range("E5") = .Range("d" & i).Value
ActiveSheet.Range("E5:H5").Select
Selection.Merge
Selection.HorizontalAlignment = xlCenter
ActiveSheet.Range("E7") = .Range("e" & i).Value
ActiveSheet.Range("E7:G7").Select
Selection.Merge
Selection.HorizontalAlignment = xlCenter
ActiveSheet.Range("E9") = .Range("D1").Value
ActiveSheet.Range("E9:G9").Select
Selection.Merge
Selection.HorizontalAlignment = xlCenter
ActiveSheet.Range("M7") = .Range("f" & i).Value
ActiveSheet.Range("M7:N7").Select
Selection.Merge
Selection.HorizontalAlignment = xlCenter
Range("$IV$65536").Select
'--------------------------
'Set Print Area and Page Setup Options
ActiveSheet.PageSetup.PrintArea = "$A$1:$W$63"
Application.SendKeys AltKey & "FU"
Application.Wait Now + TimeValue("00:00:02")
Application.SendKeys AltKey & "T"
Application.Wait Now + TimeValue("00:00:01")
Application.SendKeys AltKey & "F"
Application.Wait Now + TimeValue("00:00:01")
Application.SendKeys "1" & TabKey
Application.SendKeys "1"
Application.Wait Now + TimeValue("00:00:01")
Application.SendKeys EnterKey
Application.SendKeys "(ENTER)", False
Application.Dialogs(xlDialogPageSetup).Show _
Arg1:="", _
Arg2:="", _
Arg3:=0.15, _
Arg4:=0.15, _
Arg5:=0.15, _
Arg6:=0.15, _
Arg9:=True, _
Arg10:=True, _
Arg18:=0.15, _
Arg19:=0.15
Range("$A$1").Select
Next i
End With
'--------------------------
'calculate and clear any unnecessary keystrokes caused by sendkeys
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
End SubAnd here is the code I am trying to manipulate to run through my loops to show progress while keeping the % running.
Code:
Sub ProgressBar()
Dim frm As frmSplash
Dim x As Integer
Dim j As Long
Set frm = New frmSplash
frm.CloseMe = False
frm.ProgressBar.Value = 0
frm.Show False
'value x will change depending on which loop it is placed in
For x = 0 To 100 Step 5
frm.ProgressBar.Value = x
frm.lblPercent.Caption = x & " %"
'My code would go here ... the below is simply wasting time for testing purposes.
For j = 1 To 100000
DoEvents
Next j
Next x
frm.CloseMe = True
Unload frm
End SubAny help or suggestions would be greatly appreciated as I have all but given up hope ... fortunately the application.wait now + timevalue lines must remain, even though they slow down the code quite a bit as the sendkeys pagesetup code will fail without any delays in place.
