将工作表分割并保存为单独的文件答案

【问题标题】：divide and save worksheets as separate files将工作表分割并保存为单独的文件
【发布时间】：2017-11-21 15:00:56
【问题描述】：

我有几个名为“Copy Transposed”的相同工作表（Copy Transposed、Copy Transposed(2)、Copy Transposed(3) 等）我想编写一个宏来复制一个 Copy Transposed* 工作表与“测试1”、“测试2”、“测试3”、“测试4”、“测试5”。因此，如果我有 5 个副本转置工作表，我希望有 5 个单独的文件，其中副本转置和“Test1”、“Test2”、“Test3”、“Test4”、“Test5”。文件名应与活动工作表的名称相同。例如，我有 5 个副本转置工作表，所以：

文件 1 - Copy Transposed.xlsm 包含“Copy Transposed”、“Test1”、 “Test2”、“Test3”、“Test4”、“Test5”。
文件 2 - Copy Transposed(2).xlsm 包含“Copy Transposed(2)”， “Test1”、“Test2”、“Test3”、“Test4”、“Test5”。
文件 3 - Copy Transposed(3).xlsm 包含“Copy Transposed(3)”， “Test1”、“Test2”、“Test3”、“Test4”、“Test5”。
文件 4 - Copy Transposed(4).xlsm 包含“Copy Transposed(4)”， “Test1”、“Test2”、“Test3”、“Test4”、“Test5”。
文件 5-Copy Transposed(5).xlsm 包含“Copy Transposed(5)”， “Test1”、“Test2”、“Test3”、“Test4”、“Test5”。

“复制转置”工作表的数量总是不同的

Sub test_macro()
Dim Fname As String
Fname = Sheets("Copy Transposed").Range("A1").Value
Sheets(Array("Test1", "Test2", "Test3", "Test4", "Test5")).copy
With ActiveWorkbook
ActiveWorkbook.SaveAs ThisWorkbook.path & "\" & Fname & ".xlsm", FileFormat:=52
End With
End Sub

【问题讨论】：

stackoverflow.com/questions/19940409/…
我已经检查了这个宏，它会单独保存每个工作表，但我想要“Copy Transposed(4)”和“Test1”、“Test2”、“Test3”、“Test4”、“Test5” 1 个工作簿中的工作表
然后把这部分path & ws.Name改成你想要的。
我不确定我应该在这里更改什么。

标签： vba excel

【解决方案1】：

我对以下宏进行了现场测试，并使其正常工作。此宏查找带有字符串“Copy Transposed”的任何工作表，并使用找到的工作表和“Test1”到“Test5”的工作表创建一个工作簿。我想有更优雅的方式来实现你正在寻找的东西，但这似乎奏效了。

Sub Test()

Dim WS As Worksheet
Dim WB As Workbook
Dim SearchStr As String
Dim ShtName As String
Dim FName As String
Dim FPath As String
Dim WBNew As Workbook

Set WB = ActiveWorkbook

SearchStr = "Copy Transposed"
FPath = "C:\Users\hwyr53e\Desktop\Test Output\"

    For Each WS In WB.Sheets
        ShtName = WS.Name
        Set wshts = Sheets(Array("Test1", "Test2", "Test3", "Test4", "Test5"))
        If InStr(ShtName, SearchStr) > 0 Then
            FName = FPath & ShtName & ".xlsm"
            Set WBNew = Workbooks.Add
            wshts.Copy before:=WBNew.Sheets(1)
            WS.Copy before:=WBNew.Sheets(1)
            With WBNew
                .SaveAs FName, FileFormat:=52
            End With
            WBNew.Close
            Set WBNew = Nothing
        End If
    Next WS

End Sub

您可能希望添加一个组件来删除填充有新 Excel 实例的工作表。

让我知道这是否实现了您想要实现的目标。

【讨论】：