if you have Many Workbooks with Data in Same Format and You want to Compile all them with in a Single workbook you can use below Mention Code :-
Sub Compile()
On Error GoTo Err_Clear:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Fso As New Scripting.FileSystemObject
Dim Path As String
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder to Pick Downloaded Bills"
Application.FileDialog(msoFileDialogFolderPicker).Show
Path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If Path = "" Then Exit Sub
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder to Save Compiled File"
CompilePath = Application.FileDialog(msoFileDialogFolderPicker).Show
compiledPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If compiledPath = "" Then Exit Sub
Dim Counter
Dim File As File
Dim FOlder As FOlder
Dim wb As Workbook
Dim ws As Worksheet
Dim AcWb As Workbook
Set AcWb = ActiveWorkbook
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "Index"
Set FOlder = Fso.GetFolder(Path)
For Each File In FOlder.Files
Counter = Counter + 1
Set wb = Workbooks.Open(Path & File.Name)
wb.Sheets("Index").Activate
ActiveSheet.UsedRange.Copy
AcWb.Sheets("Index").Activate
Range("A1000000").End(xlUp).Select
ActiveSheet.Paste
Application.CutCopyMode = False
wb.Close
Next
If Counter > 0 Then
AcWb.SaveAs compiledPath & "Compiled", xlExcel12
AcWb.Close
End If
Err_Clear:
Err.Clear
Resume Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Counter < 1 Then
MsgBox "No File Found For Compile", vbInformation
Else
MsgBox Counter & " File Has been Compiled, Please Find your File at" & vbCrLf & compiledPath, vbInformation
End If
End Sub
Sub Compile()
On Error GoTo Err_Clear:
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Fso As New Scripting.FileSystemObject
Dim Path As String
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder to Pick Downloaded Bills"
Application.FileDialog(msoFileDialogFolderPicker).Show
Path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If Path = "" Then Exit Sub
Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder to Save Compiled File"
CompilePath = Application.FileDialog(msoFileDialogFolderPicker).Show
compiledPath = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If compiledPath = "" Then Exit Sub
Dim Counter
Dim File As File
Dim FOlder As FOlder
Dim wb As Workbook
Dim ws As Worksheet
Dim AcWb As Workbook
Set AcWb = ActiveWorkbook
ActiveWorkbook.Sheets.Add
ActiveSheet.Name = "Index"
Set FOlder = Fso.GetFolder(Path)
For Each File In FOlder.Files
Counter = Counter + 1
Set wb = Workbooks.Open(Path & File.Name)
wb.Sheets("Index").Activate
ActiveSheet.UsedRange.Copy
AcWb.Sheets("Index").Activate
Range("A1000000").End(xlUp).Select
ActiveSheet.Paste
Application.CutCopyMode = False
wb.Close
Next
If Counter > 0 Then
AcWb.SaveAs compiledPath & "Compiled", xlExcel12
AcWb.Close
End If
Err_Clear:
Err.Clear
Resume Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Counter < 1 Then
MsgBox "No File Found For Compile", vbInformation
Else
MsgBox Counter & " File Has been Compiled, Please Find your File at" & vbCrLf & compiledPath, vbInformation
End If
End Sub
No comments:
Post a Comment