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
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.
|How to create VBA to split data to their respective columns with character restriction|
|How to find last non blank cell & not affect split screen view|
|How to convert split formula in VBA in their respective columns|