使用VBA基于条件在工作簿中保存特定的命名工作表

Question

我正在编写一个函数来获取标记为“STORE＃01”的所有工作表，并为包含两个选项卡的目标存储创建单独的文件： 1 - 所有文件都具有相同的“比较Depts”表 2 - 与该商店关联的唯一工作表

文件必须存储为Store_01_City.xls。

当我运行宏时，我没有看到任何文件被创建。此外，我运行宏的工作簿受密码保护，但我明显输入了密码。

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

我找到了绕过旧宏密码并修改它的方法。这也有效，但比你的功能@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

更新

添加了文件选择器以获取外部工作​​簿。

我必须向VLookup添加一个参数并将Right(.Name, 2)强制转换为int。希望它从这里顺利航行。

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