Public Sub SubMain()
Dim strFiles As String
Dim strFolder As String
ActiveWorkbook.Save
strFiles = fncSelectFile(ActiveWorkbook.Path & "\", False, False)
If strFiles = "" Then
Exit Sub
End If
strFolder = fncSelectFolder(ActiveWorkbook.Path, "Select Destination Folder.")
If strFolder = "" Then
Exit Sub
End If
Call subCopySheetsToANewWorkbook(strFiles, strFolder)
ActiveWorkbook.Save
End Sub
Public Sub subCopySheetsToANewWorkbook(strWorkbook As String, strFolder As String)
Dim Ws As Worksheet
Dim WbSource As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If Not fncIsWorkbookOpen(fncGetFileNameFromFullpath(strWorkbook)) Then
Set WbSource = Application.Workbooks.Open(strWorkbook)
Else
Set WbSource = Workbooks(fncGetFileNameFromFullpath(strWorkbook))
End If
For Each Ws In WbSource.Worksheets
Ws.Copy
On Error Resume Next
Kill (strFolder & Ws.Name)
On Error GoTo 0
With ActiveWorkbook
.SaveAs Filename:=strFolder & Ws.Name, FileFormat:=51
.Close
End With
Next Ws
MsgBox WbSource.Worksheets.Count & " workbooks created from the worksheets in " & _
fncGetFileNameFromFullpath(WbSource.Name), vbOKOnly, "Confirmation"
WbSource.Close savechanges:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Public Function fncSelectFile(strInitialFolderName As String, _
blnRestrictToThisFolder As Boolean, _
blnMultipleSelection As Boolean)
Dim fd As Office.FileDialog
Dim strFiles As String
Dim strSelectedFiles As String
Dim vrtSelectedItem As Variant
If Right(strInitialFolderName, 1) <> "\" Then
strInitialFolderName = strInitialFolderName & "\"
End If
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "Excel Files", "*.xlsx?", 1
.Filters.Add "Excel Files", "*.xlsm?", 1
.Title = "Select an Excel file."
.AllowMultiSelect = blnMultipleSelection
.InitialFileName = strInitialFolderName
If .Show = True Then
For Each vrtSelectedItem In .SelectedItems
' Only add the file to the list if resides in the initial folder.
If blnRestrictToThisFolder Then
If strInitialFolderName = fncGetFolderNameFromFullpath(vrtSelectedItem) Then
strSelectedFiles = strSelectedFiles & "," & vrtSelectedItem
End If
Else
' Or add the file to the list whatever folder it comes from.
strSelectedFiles = strSelectedFiles & "," & vrtSelectedItem
End If
Next vrtSelectedItem
End If
End With
fncSelectFile = Mid(strSelectedFiles, 2)
End Function
Public Function fncGetFileNameFromFullpath(ByVal strFullPath As String) As String
Dim varSplitList As Variant
varSplitList = VBA.Split(strFullPath, "\")
fncGetFileNameFromFullpath = varSplitList(UBound(varSplitList, 1))
End Function
Public Function fncGetFolderNameFromFullpath(ByVal strFullPath As String) As String
Dim varSplitList As Variant
varSplitList = VBA.Split(strFullPath, "\")
fncGetFolderNameFromFullpath = Replace(strFullPath, varSplitList(UBound(varSplitList, 1)), "", 1)
End Function
Public Function fncIsWorkbookOpen(strWorkbook As String)
Dim Wb As Workbook
Dim strFile As String
Dim strFolder As String
For Each Wb In Application.Workbooks
If strWorkbook = fncGetFileNameFromFullpath(Wb.Name) Then
fncIsWorkbookOpen = True
Exit For
End If
Next Wb
End Function
Public Function fncSelectFolder(strInitialFolderName As String, strTitle As String) As String
Dim FldrPicker As FileDialog
Dim strFolder As String
fncSelectFolder = ""
' Retrieve Selected Folder Path From User.
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = strTitle
.InitialFileName = strInitialFolderName
If .Show <> -1 Then
Exit Function
End If
fncSelectFolder = .SelectedItems(1) & "\"
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function
