VBA Help - Progress Bar Disappears during code running

[Johnny Thunder]

Hi All,

I am working on a project that uses a Userform to display a Progress Bar of a percentage of completion. Currently I am using this to run a code that loops thru a range of values and creates new Workbooks based on those values.


From all the research I've done, I believe that my issue is coming from the code creating new worksheets and then losing the userform because a new window has opened and closed.

I've tried the Userform1.Setfocus and the Userform1.Show but these commands did not help so either I am using them in the wrong area or they are not going to work for me.

So here is my code below:

Code on Userform

Sub UserForm_Activate()


Application.ScreenUpdating = False


Call Copy_CCodes


Application.ScreenUpdating = True


End Sub

Module Code

Sub Copy_CCodes()
  
  Dim Lastrow       As Long
  Dim Datastore     As Worksheet
  Dim FinalDest     As Worksheet
  Dim rCell         As Range
  Dim Prg           As Range
  Dim i             As Integer, j As Integer, pctCompl As Single
  
  Set Datastore = Sheets("Lookups2")
  Set FinalDest = Sheets("Summary")
  
  Set Prg = Range("PrgB")
   
Lastrow = Datastore.Cells(Rows.Count, "O").End(xlUp).Row
  
'Call FindRep
  
For Each rCell In Datastore.Range("O2:O" & Lastrow)
  
  If rCell <> "" Then
           
FinalDest.Range("RPTCC").Value = rCell.Value


'Call FindColVal


Calculate


'--------------------------------Lines for Userform Progress Bar-------------------------------
    pctCompl = Format(Prg, "#,##0") * 100 / 68
    progress Format(pctCompl, "#,##0") 'formats the results with no decimals


    UserForm1.Text.Caption = Format(pctCompl, "#,##0") & "% Completed"
    UserForm1.Bar.Width = pctCompl * 2
          
    Call SaveSheet
                       
    End If
                       
    Next rCell 'Loop for CC Codes
             
'Call CountFiles


Application.CutCopyMode = False
  
Sheets("Summary").Activate
  
 End Sub
Sub progress(pctCompl As Single)


UserForm1.Text.Caption = Format(pctCompl, "#,##0") & "% Completed"
UserForm1.Bar.Width = pctCompl * 2


DoEvents


End Sub

Sub SaveSheet()
 
Dim nW      As Workbook
Dim dt      As String, CCenter As String, Year As String, Month As String, ShtNM As String, cspath As String, cMonth As String, wbNam As String




cMonth = Sheets("Lookups & tables").Range("CurMonth").Value
Year = Sheets("Lookups & Tables").Range("Cyear").Value
Month = Sheets("Lookups2").Range("FolderL").Value
ShtNM = Sheets("Summary").Range("ShtName").Value


Application.DisplayAlerts = False
Application.ScreenUpdating = False


cspath = "C:User\Johnny\My Report\"


Sheets("Summary").Cells.Copy
    
'Creates new copy of the sheet to a new workbook
Set nW = Application.Workbooks.Add
'Application.SheetsInNewWorkbook = 2


With nW
    .Sheets("Sheet1").Name = ShtNM
        .Sheets("Sheet2").Name = "By-Account"
End With


With nW.Sheets(ShtNM).Range("A1")
    .PasteSpecial xlPasteColumnWidths
       .PasteSpecial xlPasteValues, , False, False
         .PasteSpecial xlPasteFormats, , False, False
    
    ActiveSheet.Outline.ShowLevels RowLevels:=1
        Columns("A").Hidden = True ' Hide Columns and rows with lookup criteria
             .Range("A1").Select
                  Application.CutCopyMode = False ' Clears Clipboard
                End With
              
Call PrintArea
              
'If 3 sheets show up in the newly added workbook
'With nW
 '   .Sheets("sheet3").Delete
'End With


ThisWorkbook.Sheets("By-Account").Cells.Copy
    
nW.Sheets("By-Account").Activate


With nW.Sheets("By-Account").Range("A1")
  .PasteSpecial xlPasteValues
      .PasteSpecial xlPasteFormats
         Application.CutCopyMode = False ' Clears Clipboard
         ActiveCell.Select
            ActiveSheet.Outline.ShowLevels ColumnLevels:=1
                ActiveSheet.Outline.ShowLevels RowLevels:=1
                    Columns("A").Hidden = True ' Hide Columns and rows with lookup criteria
                    Application.CutCopyMode = False
                                  
        End With


Call PrintAreaByACT


wbNam = "P" & cMonth & " 2018 OH Reporting - " & Range("A9").Value 'Creates the File Name
dt = Format(CStr(Now), " - yyyymmdd")


 ActiveWorkbook.SaveAs Filename:= _
    cspath & wbNam & ".xlsx"
     'csPath & wbNam & dt & ".xlsx" Adds date at the end
          
     ActiveWorkbook.Close True


End Sub

 

[davesexcel]

Not an answer, just curious, if setting screenupdating to false, would that mean you would not see the userform updating

 

[Johnny Thunder]

No, it would just cause the screen flickering not to happen. But that was also something I recently added in hopes to solve this problem so even without those lines the problem persists.

 

[Kmenon]

i am also facing a problem partly similar to this. My progress bar fully works with files of smaller sizes, but in case of very large files it disappears after showing for some time. I am not sure whether this is due to consumption of more memory while processing the file. If anyone with a solution, kindly assist. Thanks.