'==========================================CHIRAG MITTAL==============================================
'Project Developed by Chirag Mittal
'Project Name :- Update worksheets data in each workbook in specfic folder
Option Explicit
Sub toolkit()
Dim wb As Workbook 'input File that that will update
Dim mypath As String ' select folder path where all input file saved(those need to be update)
Dim myfile As String 'foldr name where all input file saved
Dim myext As String ' only selected file ext will be update
Dim fldrpicker As FileDialog ' vba function
Dim tb As FileDialog 'Raw file1 that data to be update
Dim myfile1 As String ' filename
Dim Ratefl As FileDialog 'vba function
Dim tbfl As Workbook
Dim i As Long
Dim TBsheet As String
'=====================================================================================================================
'= This code is use to maximize the macro speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'=====================================================================================================================
'Retrieve Target Folder Path From User
Set fldrpicker = Application.FileDialog(msoFileDialogFolderPicker)
With fldrpicker
.Title = "Select folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
mypath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
mypath = mypath
If mypath = "" Then GoTo ResetSettings
'==================================================================================
'Raw file 1 update
'Retrieve TB File From User
Set tb = Application.FileDialog(msoFileDialogFilePicker)
With fldrpicker
.Title = "Select folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode1
myfile1 = .SelectedItems(1)
End With
'In Case of Cancel
NextCode1:
myfile1 = myfile1
If myfile1 = "" Then
GoTo ResetSettings
Else
Workbooks.Open (myfile1)
Set tbfl = ActiveWorkbook
End If
'=====================================================================================
'Target File Extension (must include wildcard "*")
myext = "*.xls*"
'Target Path with Ending Extention
myfile = Dir(mypath & myext)
'Loop through each Excel file in folder
Do While myfile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=mypath & myfile)
'Check TB worksheet exist or not in template
TBsheet = "paprika TB"
For i = 1 To wb.Worksheets.Count
If wb.Worksheets(i).Name = TBsheet Then
Exit For
Else
If i = wb.Worksheets.Count Then
wb.Worksheets.Add.Name = TBsheet
Else
End If
End If
Next i
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
tbfl.Activate
Range("A1").CurrentRegion.Select
Range("A1").CurrentRegion.Copy
wb.Activate
Range("A1").Select
Range("A1").PasteSpecial xlPasteValuesAndNumberFormats
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myfile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
0 Comments