Sub Consolidation_Sheets()
Dim Sheets_Count As Integer
Dim fso As Object
Dim selectedpath As String
Dim strpath As Object
Set fso = CreateObject("scripting.filesystemobject")
fso.createfolder ThisWorkbook.Path & "\Destination"
Workbooks.Add
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\Destination\OutputFile.xlsx"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = "Please select Files Folder"
.Title = "Please select Files Folder"
MsgBox "Please select Folder"
If .Show = True Then
selectedpath = .SelectedItems(1) & "\"
Else
MsgBox "User has cancelled"
Exit Sub
End If
End With
For Each strpath In fso.getfolder(selectedpath).Files
Workbooks.Open strpath
Z = ActiveWorkbook.Sheets.Count
y = 0
For Sheets_Count = ActiveWorkbook.Sheets.Count To 1 Step -1
x = Workbooks("OutputFile.xlsx").Sheets.Count
y = y + 1
ActiveWorkbook.Sheets(Sheets_Count).Copy after:=Workbooks("OutputFile.xlsx").Sheets(x)
Workbooks("OutputFile.xlsx").Save
If y = 2 Then
strpath1 = Right(strpath, Len(strpath) - Len(selectedpath))
Workbooks(strpath1).Close
Exit For
End If
Next Sheets_Count
If Z = 1 Then
strpath1 = Right(strpath, Len(strpath) - Len(selectedpath))
Workbooks(strpath1).Close
End If
Next strpath
End Sub
--------------------------------------------------------------------------------------------------------------------------
Copying sheets from one file to multiple files
Sub Consolidation_Sheets()
Dim Sheets_Count As Integer
Dim fso As Object
Dim selectedpath As String
Dim strpath As Object
Application.DisplayAlerts = False
Set fso = CreateObject("scripting.filesystemobject")
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.InitialFileName = "Please select Files Folder"
.Title = "Please select Files Folder"
MsgBox "Please select Folder"
If .Show = True Then
selectedpath = .SelectedItems(1) & "\"
Else
MsgBox "User has cancelled"
Exit Sub
End If
End With
For Each strpath In fso.getfolder(selectedpath).Files
If Right(strpath, Len(strpath) - Len(selectedpath)) = "Testing.xlsx" Then
Workbooks.Open strpath
Exit For
End If
Next strpath
For Each strpath In fso.getfolder(selectedpath).Files
If Right(strpath, Len(strpath) - Len(selectedpath)) <> "Testing.xlsx" Or Right(strpath, Len(strpath) - Len(selectedpath)) <> "~$Testing.xlsx" Then
Workbooks.Open strpath
strpath1 = Right(strpath, Len(strpath) - Len(selectedpath))
Workbooks("Testing.xlsx").Sheets(Workbooks("Testing.xlsx").Sheets.Count).Copy after:=Workbooks(strpath1).Sheets(Workbooks(strpath1).Sheets.Count)
Workbooks("Testing.xlsx").Sheets(Workbooks("Testing.xlsx").Sheets.Count - 1).Copy after:=Workbooks(strpath1).Sheets(Workbooks(strpath1).Sheets.Count)
Workbooks(strpath1).Save
Workbooks(strpath1).Close
End If
Next strpath
Workbooks("Testing.xlsx").Close
End Sub
