VBA code to show progress percentage while running a macro

[abhirupganguli123]

Hi,
Can anyone please help me to modify the below code to insert a progress bar while the macro is running. This macro actually pulls data from different tabs of all excel files situated in a selected folder and pastes it into a master sheet. I want to see the percentage of the progress while the macro performs. Can anyone please help me ?

Sub ImportWorksheets()
   '=============================================
   'Process all Excel files in specified folder
   '=============================================
   Dim sFile As String           'file to process
   Dim wsTarget As Worksheet
   Dim wbSource As Workbook
   Dim wsSource As Worksheet
   Dim rowTarget As Long         'output row
   Dim sPath As String
   Dim wb1 As Workbook
   Dim fname
   Dim Count As Integer
  
Application.DisplayAlerts = False
        
fname = InputBox("Enter the reporting week")rowTarget = 3
   
MsgBox "Select the Source data folder"
     
   With Application.FileDialog(msoFileDialogFolderPicker)
 .Title = "Please select one folder"
 .AllowMultiSelect = False
 If .Show = True Then
 sPath = .SelectedItems(1) & "\"
 End If
 End With
 
sFile = Dir(sPath & "*.xls*")
 If sFile <> "" Then
Application.ScreenUpdating = False
End If
 
  
   'check the folder exists
   If Not FileFolderExists(sPath) Then
      MsgBox "No files in the specified folder, exiting!"
      Exit Sub
   End If
   
   'reset application settings in event of error
   On Error GoTo errHandler
   Application.ScreenUpdating = False
   
   'set up the target worksheet
  ' Workbooks.Add
   MsgBox "Select the Data Analysis file !"

FileToOpen = Application.GetOpenFilename _
(Title:="Please Select the New data file", _
FileFilter:="Excel Files *.xls; *.xlsx; *.xlsm,")
If FileToOpen = False Then
    MsgBox "No File Specified.", vbExclamation, "ERROR"
    Exit Sub
Else
    Set wb1 = Workbooks.Open(filename:=FileToOpen)
    
   Set wsTarget = wb1.Sheets(1)
   
   
End If
   'loop through the Excel files in the folder
   sFile = Dir(sPath & "*.xls*")
   Do Until sFile = ""
      
      
      
      'open the source file and set the source worksheet - ASSUMED WORKSHEET(3)
      Set wbSource = Workbooks.Open(sPath & sFile)
      Set wsSource = wbSource.Worksheets(3) 'EDIT IF NECESSARY
      
      'import the data
      With wsTarget
         .Range("B" & rowTarget).Value = wsSource.Range("I17").Value
         .Range("C" & rowTarget).Value = wsSource.Range("J17").Value
        
      Set wsSource = wbSource.Worksheets(4) 'EDIT IF NECESSARY
      
      'import the data
      
         .Range("D" & rowTarget).Value = wsSource.Range("H17").Value
         .Range("E" & rowTarget).Value = wsSource.Range("I17").Value
                
        Set wsSource = wbSource.Worksheets(5) 'EDIT IF NECESSARY
      
      'import the data
      
         .Range("F" & rowTarget).Value = wsSource.Range("H17").Value
         .Range("G" & rowTarget).Value = wsSource.Range("I17").Value
         
          Set wsSource = wbSource.Worksheets(6) 'EDIT IF NECESSARY
      
      'import the data
      
         .Range("H" & rowTarget).Value = wsSource.Range("H17").Value
         .Range("I" & rowTarget).Value = wsSource.Range("I17").Value
         
         Set wsSource = wbSource.Worksheets(7) 'EDIT IF NECESSARY
      
      'import the data
      
         .Range("J" & rowTarget).Value = wsSource.Range("H17").Value
         .Range("K" & rowTarget).Value = wsSource.Range("I17").Value
         
         
          Set wsSource = wbSource.Worksheets(8) 'EDIT IF NECESSARY
      
      'import the data
      
         .Range("L" & rowTarget).Value = wsSource.Range("H17").Value
         .Range("M" & rowTarget).Value = wsSource.Range("I17").Value
         
         
          Set wsSource = wbSource.Worksheets(9) 'EDIT IF NECESSARY
      
      'import the data
      
         .Range("N" & rowTarget).Value = wsSource.Range("H17").Value
         .Range("O" & rowTarget).Value = wsSource.Range("I17").Value
         
        
         'optional source filename in the first column
         .Range("A" & rowTarget).Value = sFile
        End With
        
  
      
      'close the source workbook, increment the output row and get the next file
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()
   Loop
   
errHandler:
   On Error Resume Next
   
   'Remove the extension and other text from the printed file name
    wsTarget.Activate
    Columns("A:A").Select
    Selection.Replace What:="_*.xls*", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
wsTarget.Columns("A:Q").EntireColumn.AutoFit
'Print the Week in cell A1 in sheet1
Range("A1").Select
Range("A1").Value = "Week = " & fname
Selection.Font.Bold = True
    valRow = 2
    valCol = 3
'Print the Week in cell C2 from Sheet2 till last sheet
    For x = 2 To Sheets.Count
        Sheets(x).Cells(valRow, valCol).Value = "Week = " & fname
    Next x
    
    For x = 2 To Sheets.Count
        Sheets(x).Cells(valRow, valCol).Font.Bold = True
    Next x
    
    Sheets(2).Activate
    
    
    Count = wsTarget.Range("A1").End(xlDown).Row - 2
    
wb1.Close SaveChanges:=True, filename:="InQube - Performance Analysis_" & "Week " & fname & ".xls"
   Set wsSource = Nothing
   Set wbSource = Nothing
   Set wsTarget = Nothing
   
   Application.ScreenUpdating = True
   
   filename = ActiveWorkbook.Path + "\InQube - Performance Analysis_" & "Week " & fname & ".xls"
   
   MsgBox Count & " agent wise files have been analysed." & vbNewLine & vbNewLine & "Weekly Performance Analysis File Generated Successfully In The Folder Path - " & ThisWorkbook.Path
   
    Dim nResult As Long
    nResult = MsgBox(Prompt:="Do you want to open the file?", Buttons:=vbYesNo)
    If nResult = vbYes Then
        Workbooks.Open (filename)
        Application.StatusBar = "opening " & filename
    End If
    Application.StatusBar = "Done"
   
Application.DisplayAlerts = True
   
End Sub
 

Private Function FileFolderExists(strPath As String) As Boolean
    If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function

 

[rlv01]

The quick and easy way is to use Application.StatusBar

 Application.StatusBar = "Processing File: " & sFile

Beyond that, the next level is coding userform-based progress bars. Google "excel vba progress bar". There are a lot of examples.

 

[abhirupganguli123]

Hi,

I actually need a userform based percentage progress bar. I have seen many solutions in website, but could not put the progress bar code correctly in my original code. Is it possible to give me a solution code please with userform based percentage progress bar ?

Thanks a lot for your help.

 

[Fluff]

Have a look here http://www.andypope.info/vba/pmeter.htm

 

[abhirupganguli123]

Thank you for your help. But I am not a VBA expert. Could you please help me how to put my codes into it ?

 

[pmich]

Please try this code. You should have Frame and Label. If you find this useful, plug it in your code.

Private Sub cmdCalculateOneToOneThousand_Click()
 'http://www.endprod.com/colors/
 'http://dmcritchie.mvps.org/excel/colors.htm
 'http://www.mrexcel.com/forum/excel-questions/556775-excel-visual-basic-applications-progress-bar.html
 'http://stackoverflow.com/questions/9385689/how-to-calculate-elapsed-time-in-seconds-in-vba
 'https://www.mrexcel.com/forum/excel-questions/756038-simple-timer-clock-userform-vba.html
 Dim UsrBegnAssoNum As Long
 Dim UsrEndAssoNum As Long
 Dim TotRunNeededAssoDataMaxRows As Long
 Dim pctCntAssoDataMaxRows As Long
 pctCntAssoDataMaxRows = 0
 Dim PrcntgCompletedAssoDataMaxRows As Single
 PrcntgCompletedAssoDataMaxRows = 0
 Dim Roller As Long
 Dim prcntbyrun As Currency
 Application.ScreenUpdating = False
   If FrameProgress.Visible = False Then
     FrameProgress.Visible = True
   End If
   If LabelProgress.Visible = False Then
     LabelProgress.Visible = True
   End If
GetAgainFirstAsoNumbr:
 UsrBegnAssoNum = Application.InputBox _
  (Prompt:="Type 1 or any other First Number to Display", _
  Title:="First Number should be 1 or greater.", Type:=1)
 If Len(Trim(Str(UsrBegnAssoNum))) = 0 Then
  MsgBox "You typed: " & UsrBegnAssoNum & "." & vbCrLf & _
   "This is not a valid number." & vbCrLf & _
   "Type a Number either 1 or greater."
  GoTo GetAgainFirstAsoNumbr:
 ElseIf UsrBegnAssoNum < 1 Then
  MsgBox "You typed: " & UsrBegnAssoNum & "." & vbCrLf & _
   "This is not a valid number." & vbCrLf & _
   "Type a Number either 1 or greater."
  GoTo GetAgainFirstAsoNumbr:
 End If
 
GetAgainLastAsoNumbr:
 UsrEndAssoNum = Application.InputBox _
  (Prompt:="Type 1000 or any Last Number to Display", _
  Title:="Last Number should be 2 or greater.", Type:=1)
 If Len(Trim(Str(UsrEndAssoNum))) = 0 Then
  MsgBox "You typed: " & UsrEndAssoNum & "." & vbCrLf & _
   "This is not a valid number." & vbCrLf & _
   "Type a Number either 2 or greater."
  GoTo GetAgainLastAsoNumbr:
 ElseIf UsrEndAssoNum <= 1 Then
  MsgBox "You typed: " & UsrEndAssoNum & "." & vbCrLf & _
   "This is not a valid number." & vbCrLf & _
   "Type a Number either 2 or greater."
  GoTo GetAgainLastAsoNumbr:
 End If
 FrameProgress.Caption = "Preparing. Wait"
 LabelProgress.Width = 0
 FrameProgress.BackColor = RGB(205, 51, 51) 'Brown
 FrameProgress.ForeColor = RGB(255, 228, 196) 'BISQUE
 LabelProgress.BackColor = RGB(0, 255, 255)  'AQUA
 TotRunNeededAssoDataMaxRows = (UsrEndAssoNum - UsrBegnAssoNum) + 1
 Do While TotRunNeededAssoDataMaxRows > 0
  For Roller = 1 To 500000
  Next
  pctCntAssoDataMaxRows = pctCntAssoDataMaxRows + 1
  ' Update the percentage completed.
  TotRunNeededAssoDataMaxRows = TotRunNeededAssoDataMaxRows - 1
  If TotRunNeededAssoDataMaxRows = 0 Then
   Application.ScreenUpdating = True
   FrameProgress.Visible = False
  End If
  If TotRunNeededAssoDataMaxRows > 0 Then
   prcntbyrun = Val(pctCntAssoDataMaxRows / TotRunNeededAssoDataMaxRows) * 100
  End If
  prcntbyrun = Format(prcntbyrun, "0")
  PrcntgCompletedAssoDataMaxRows = Val(prcntbyrun)
  If PrcntgCompletedAssoDataMaxRows > 100 Then
   PrcntgCompletedAssoDataMaxRows = 100
  End If
  PrcntgCompletedAssoDataMaxRows = Format(PrcntgCompletedAssoDataMaxRows, "0")
  ' Update the Caption property of the Frame control.
  If PrcntgCompletedAssoDataMaxRows < 100 Then
   FrameProgress.Caption = "Collecting Data : " & _
    PrcntgCompletedAssoDataMaxRows & "% Completed! Wait!"
  Else 'PrcntgCompletedAssoDataMaxRows < 100
   FrameProgress.Caption = "Data Collection: " & _
    PrcntgCompletedAssoDataMaxRows & "% Completed! Displaying Data. Wait! Wait! Wait!"
   LabelProgress.Visible = False
   FrameProgress.BackColor = RGB(38, 38, 255) 'Blue
   MsgBox "Displaying Data. Wait! Wait! Wait!"
   Exit Do
  End If 'PrcntgCompletedAssoDataMaxRows < 100
  If LabelProgress.Visible = True Then
   LabelProgress.Width = ((PrcntgCompletedAssoDataMaxRows * _
    (FrameProgress.Width - 180)) / 100)
  End If
  DoEvents
 Loop
 FrameProgress.Caption = ""
 If FrameProgress.Visible = True Then
  FrameProgress.Visible = False
 End If
 LabelProgress.Caption = ""
 If LabelProgress.Visible = True Then
  LabelProgress.Visible = False
 End If
End Sub