将 Excel 工作簿拆分为单独的文件，然后根据唯一列保存在单独的文件夹中

Question

我正在尝试将一个包含多个工作表的 excel 文件拆分为单独的文件，然后根据唯一的列将它们保存在单独的文件夹中。

因此，每个工作表的 A 列都标有“AgencyName”。大约有80个机构。我在一个文件中为所有这些机构提供了 80 个工作表。

目标：使用 A 列作为文件名拆分这些文件，然后将它们保存在以每个机构命名的文件夹中。

例如：该机构是“底特律”。我有一个“底特律”的工作表和一个名称完全相同的文件夹。我想将此工作表另存为 Detroit 文件夹下的单独文件。

我们将不胜感激。

Answer 1

用于创建文件夹 -- 使用 filesystemobject (MORE HERE)

从 MSDN 创建文件夹的示例脚本...

Function CreateFolderDemo
   Dim fso, f
   Set fso = CreateObject("Scripting.FileSystemObject")
   Set f = fso.CreateFolder("c:\New Folder")
   CreateFolderDemo = f.Path
End Function

现在 - 另一个问题是创建一个新工作簿并向其中添加您需要的任何工作表。在StackOverflow here! 上查看此答案，或者您可以阅读MSDN on it here！

示例脚本可能看起来像...

Dim newWorkBook As Workbook
Dim FileName As String
FileName = "C:\blabla\Detroit\Detroit.xls"
Set newWorkBook = Workbooks.Add(FileName)

Answer 2

未经测试：

Sub Tester()

    Const DEST As String = "C:\stuff\agencies\" 'adjust to suit...

    Dim wbSrc As Workbook, sht As Worksheet, agency As String
    Dim fldr As String

    Set wbSrc = ActiveWorkbook

    For Each sht In wbSrc.Worksheets

        agency = sht.Range("A2").Value

        sht.Copy
        fldr = DEST & agency
        If Dir(fldr, vbDirectory) <> "" Then
            With ActiveWorkbook
                .SaveAs fldr & "\data.xlsx"
                .Close False
            End With
        Else
            MsgBox "Sub-folder '" & fldr & "' not found!"
        End If

    Next sht

End Sub

Answer 3

以下宏会将每个工作表保存为新工作簿中的单个工作表：

Option Explicit

Public Sub SplitFile()
    Const dstTopLevelPath       As String = "C:\MyData\AgencyStuff"
    Dim dstFolder               As String
    Dim dstFilename             As String
    Dim dstWB                   As Workbook
    Dim dstWS                   As Worksheet
    Dim srcWB                   As Workbook
    Dim srcWS                   As Worksheet
    Dim Agency                  As String

    'Ensure the destination path exists
    If Dir(dstTopLevelPath, vbDirectory) = "" Then
        MsgBox dstTopLevelPath & " doesn't exist - please create it before running this macro"
        End
    End If

    Set srcWB = ActiveWorkbook

    For Each srcWS In srcWB.Worksheets
        'Get the Agency name
        '(use this line if the Agency name is in cell A2 of each worksheet)
        Agency = srcWS.Range("A2").Value

        '(use this line if the Agency name is the actual worksheet name)
        'Agency = srcWS.Name

        'Create the destination path
        dstFolder = dstTopLevelPath & "\" & Agency

        'Create the destination file name
        '(use this line if you want the new workbooks to have a name equal to the agency name)
        dstFilename = dstFolder & "\" & Agency & ".xlsx"

        '(use this line if you want the new workbooks to have the same name as your existing workbook)
        '(Note: If your existing workbook is called "xyz.xlsm", the new workbooks will have a ".xlsm"
        ' extension, even though there won't be any macros in them.)
        'dstFilename = dstFolder & "\" & srcWB.Name

        '(use this line if you want the new workbooks to have a fixed name)
        'dstFilename = dstFolder & "\data.xlsx"

        'Create a new workbook
        Set dstWB = Workbooks.Add

        'Copy the current sheet to the new workbook
        srcWS.Copy Before:=dstWB.Sheets(1)

        'Get rid of any sheets automatically created in the new workbook ("Sheet1", "Sheet2", etc)
        For Each dstWS In dstWB.Worksheets
            If dstWS.Name <> srcWS.Name Then
                Application.DisplayAlerts = False
                dstWS.Delete
                Application.DisplayAlerts = True
            End If
        Next

        'Ensure the new location exists, and create it if it doesn't
        If Dir(dstFolder, vbDirectory) = "" Then
            MkDir dstFolder
        End If

        'Save the new workbook to the required location
        dstWB.SaveAs dstFilename

        'Close the new workbook
        dstWB.Close

    Next

    MsgBox "Finished"
End Sub

（假设您的所有源工作表都没有诸如“Sheet1”、“Sheet2”等名称）