How to Finding a value in a sheet and give back related data to another sheet

How to use VBA - Split Worksheets and Display SaveAs Prompt

Requirement:

The user is trying to enhance an existing workbook by adding code to split each worksheet into its own workbook and save them all as .xlsx files (file name = ws name & Cell B10 on main worksheet.).

The desired behavior is for a folder prompt to display, have the user select the path, then apply that path to each of the files to be saved. In most cases, there will only be two worksheets; it would be nice to allow for hidden worksheets and exclude them.

The user has assembled a couple of codes from forum searches and below is what the User is using. The split/save sub seems to be working correctly (currently saves to wb1.Path). The user just can't get the GetPath function to pass the path to the save sub.



'Dialogue box to select save folder
Function GetPath() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
'.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetPath = sItem
Set fldr = Nothing
End Function

Sub SplitWBErrorHandling()

Dim wb1 As Workbook, wb2 As Workbook
Dim ws As Worksheet
Dim sPath1 As String, sPath2 As String
Set wb1 = ThisWorkbook
sPath1 = wb1.Path

'Function to get file path
GetPath

For Each ws In wb1.Worksheets
If ws.Visible Then
ws.Copy
Set wb2 = ActiveWorkbook
sPath2 = sPath1 & ws.Name

On Error Resume Next
Kill sPath2 & ".xlsx"
On Error GoTo 0

On Error GoTo CanNotSaveIt
Call wb2.SaveAs(sPath2, xlOpenXMLWorkbook)
Call wb2.Close(False)

End If
Next

wb1.Activate

Exit Sub

CanNotSaveIt:
Call MsgBox("Can not save" & vbCrLf & vbCrLf & sPath2, vbCritical + vbOKOnly, "Split Workbook")
Resume Next
End Sub

Solution:

Code:

Option Explicit

Const mstrCellWithName As String = "NTP!C10"

'Dialogue box to select save folder
Function GetPath() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path & Application.PathSeparator
        If .Show = -1 Then
            GetPath = .SelectedItems(1)
        End If
    End With
End Function

Sub SplitWBErrorHandling()
    
    Dim sFolderPath As String, strMes As String
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws As Worksheet
    Dim sFileFullname As String, sEndName As String
    Dim iSkipped As Integer
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Set wb1 = ThisWorkbook
    
    'Function to get file path
    sFolderPath = GetPath
    If sFolderPath = "" Then
        strMes = "Folder not selected."
        GoTo NoFolder
    End If
    
    sEndName = Range(mstrCellWithName).Value
    
    For Each ws In wb1.Worksheets
        If ws.Visible Then
            ws.Copy
            Set wb2 = ActiveWorkbook
            sFileFullname = sFolderPath & Application.PathSeparator & ws.Name
            sFileFullname = sFileFullname & sEndName & ".xlsx"
            
            On Error GoTo CanNotSaveIt
            Call wb2.SaveAs(sFileFullname, xlOpenXMLWorkbook)
            On Error GoTo ErrHandler
            
            Call wb2.Close(False)
        End If
    Next
    
    wb1.Activate
    
    If iSkipped = 0 Then
        strMes = "Job done"
    Else
        strMes = "Job done. " & vbCrLf & iSkipped & " sheet(s) skipped."
    End If
    MsgBox strMes, vbInformation, "Success"

ProcEnd:
    Application.ScreenUpdating = True
Exit Sub
    
NoFolder:
    MsgBox strMes, vbInformation, "Terminating"
    GoTo ProcEnd
    
CanNotSaveIt:
    ' file already exists in the location
    ' if you click No or Cancel to replace the file then we skip the saving here
    iSkipped = iSkipped + 1
    Resume Next
    
ErrHandler:
    strMes = "Unexpected error..." & vbCrLf
    strMes = strMes & Err & " - " & Err.Description & vbCrLf
    strMes = strMes & "Terminating macro."
    MsgBox strMes, vbInformation, "Error"
    GoTo ProcEnd
End Sub

Obtained from the OzGrid Help Forum.

Solution provided by syss.