使用VBA根据条件将特定的命名工作表保存在工作簿中 [英] Saving specific named worksheets in workbook based on criteria using VBA

问题描述

我正在编写一个函数来处理所有标记为"STORE#01"的工作表，并为包含两个选项卡的到达存储区创建单独的文件:1-所有文件都将具有相同的比较部门"表2-与该商店关联的唯一工作表

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

文件必须存储为Store_01_City.xls.

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

我找到了一种绕过旧宏的密码的方法，并对其进行了修改.这也可以，但是比您的功能@Thomas Inzina慢得多

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

推荐答案

已更新

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

Updated

File picker added to get the external workbook.

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

这篇关于使用VBA根据条件将特定的命名工作表保存在工作簿中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！