abhirupganguli123
Board Regular
- Joined
- Feb 25, 2014
- Messages
- 55
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 ?
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 ?
Code:
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