Saving specific named worksheets in workbook based

Question

I am writing a function to take all the worksheets labeled "STORE #01" and create separate files for reach store that contain two tabs: 1 - The same "Compare Depts" sheet which all files will have 2 - The unique sheet associated with that store

Files must be stored as Store_01_City.xls.

When I run the macro, I do not see any files created. Also, the workbook I am running the macro in is password protected but I have entered the password obviously.

Sub SplitBook()
Dim xPath As String
Dim FilePath As String
xPath = Application.ThisWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For Each xWs In ThisWorkbook.Worksheets
        If InStr(xWs.Name, "Store") <> 0 Then
            Dim WB As Workbook
            Set WB = xWs.Application.Workbooks.Add
            ThisWorkbook.Sheets("Compare Depts").Copy Before:=WB.Sheets(1)
            Sheets(xWs.Name).Copy Before:=WB.Sheets(2)

            FilePath = "\" & Left(xWs.Name, 5) & "_" & Right(xWs.Name, 2) 
      & "_" & Application.ThisWorkbook.VLookup(Right(xWs.Name, 2), 
          ThisWorkbook.Sheets("Table").Range(H3, K100), 4)

            WB.SaveAs Filename:=xPath & FilePath & ".xls"
            WB.Close SaveChanges:=False
            Set WB = Nothing
        End If
    Next xWs
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

I found a way to by-pass the password for the old Macro and modified it. This also works, but is much slower than your function @Thomas Inzina

Sub ProcessStoreDistribution()

    Application.DisplayAlerts = False

    For Each c In ThisWorkbook.Sheets("Table").Range("StoreList")
      Process c
    Next c


    Application.DisplayAlerts = True
    MsgBox prompt:="Process Completed"
End Sub


Sub Process(ByVal c As Integer)

Dim wb As Workbook
ThisWorkbook.Activate

StoreNum = WorksheetFunction.VLookup(c, Sheets("Table").Range("StoreTable"), 2)
StoreName = WorksheetFunction.Proper(WorksheetFunction.VLookup(c, Sheets("Table").Range("StoreTable"), 5))
myST = "STORE #" & Right(StoreNum, 2)
mySTN = WorksheetFunction.Substitute(WorksheetFunction.Substitute(ActiveWorkbook.FullName, "PPE", "(PPE"), ".xlsm", ") Store Distribution Files")

Application.DisplayAlerts = False

    Sheets(Array("COMPARE DEPTS", myST)).Select
    Sheets(Array("COMPARE DEPTS", myST)).Copy
    Set wb = ActiveWorkbook

    Sheets(Array("COMPARE DEPTS", myST)).Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues

    Sheets("COMPARE DEPTS").Activate
    Application.CutCopyMode = False

    If Len(Dir(mySTN, vbDirectory)) = 0 Then
        MkDir mySTN
    End If

    mySTN = mySTN & "\STORE_" & StoreNum & "_" & StoreName & ".xls"
    wb.SaveAs Filename:=mySTN _
        , FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    ActiveWindow.Close
    ThisWorkbook.Activate
    Application.DisplayAlerts = True

End Sub

Answer 1

Updated

File picker added to get the external workbook.

I had to add a parameter to the VLookup and cast Right(.Name, 2) to an int. Hopefully it's smooth sailing from here.

Option Explicit

Sub ProcessExternalWorkBook()
    Dim ExternalFilePath As String, password As String
    ExternalFilePath = GetExcelWorkBookPath

    If Len(ExternalFilePath) Then
        password = Application.InputBox(Prompt:="Enter Password applicable", Type:=2)
        SplitBook ExternalFilePath, password
    End If

End Sub


Function GetExcelWorkBookPath() As String

    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select a Excel WorkBook"
        .AllowMultiSelect = False
        .InitialFileName = "Path"
        .Filters.Clear
        .Filters.Add "Excel WorkBooks", "*.xls, *.xlsx, *.xlsm, *.xlsb"
        If .Show = -1 Then
            GetExcelWorkBookPath = .SelectedItems(1)
        End If
    End With

End Function

Sub SplitBook(ExternalFilePath As String, Optional sPassword As String)

    Dim FilePath As String
    Dim wb As Workbook, wbSource As Workbook
    Dim xWs As Worksheet
    Dim Secured

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set wbSource = Application.Workbooks.Open(Filename:=ExternalFilePath, ReadOnly:=True, password:=sPassword)

    For Each xWs In wbSource.Worksheets
        If InStr(xWs.Name, "Store") <> 0 Then
            Debug.Print xWs.Name & ": was processed"

            FilePath = getNewFilePath(xWs)
            If Len(FilePath) Then
                Sheets(Array("Compare Depts", xWs.Name)).Copy
                Set wb = ActiveWorkbook
                wb.SaveAs Filename:=FilePath, _
                          FileFormat:=xlExcel8, password:="", WriteResPassword:="", _
                          ReadOnlyRecommended:=False, CreateBackup:=False
                wb.Close SaveChanges:=False
            Else
                MsgBox xWs.Name & " was not found by VLookup", vbInformation
            End If
        Else
            Debug.Print xWs.Name & ": was skipped"
        End If
    Next xWs

    Set wb = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Function getNewFilePath(xWs As Worksheet) As String
    Dim s As String, sLookup As String

    On Error Resume Next
    With xWs

        sLookup = WorksheetFunction.VLookup(CInt(Right(.Name, 2)), .Parent.Sheets("Table").Range("H3", "K100"), 4, False)

        s = ThisWorkbook.Path & "\"

        s = s & Left(.Name, 5) & "_" & Right(.Name, 2) & "_" & sLookup

        If Err.Number = 0 Then getNewFilePath = s & ".xls"
    End With
    On Error GoTo 0

End Function

Function getCellValue(cell)
    Dim s
    s = cell.innerHTML
    s = Replace(s, "<br>", "")
    s = Replace(s, "<br />", "")
    getCellValue = s
End Function