Excelのワークブックを別々のファイルに分割し、固有の列に基づいて別々のフォルダに保存します。

Question

複数のワークシートを含む1つのExcelファイルを別々のファイルに分割し、独自の列に基づいて別々のフォルダに保存しようとしています。

したがって、各ワークシートの列Aには "AgencyName"というラベルが付けられています。約80の代理店があります。私はこれらの機関のために1つのファイルに80のワークシートを持っています。

目的：列Aをファイル名として使用してこれらのファイルを分割し、各代理店の名前を付けたフォルダに保存します。

たとえば、代理店の「デトロイト」です。 「デトロイト」のワークシートと全く同じ名前のフォルダがあります。私はこのワークシートをDetroit Folderの下に別のファイルとして保存したいと思います。

ご協力いただければ幸いです。フォルダを作成するための

Answer 1

- 今

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

... MSDNからフォルダを作成するために、FileSystemObjectオブジェクト（MORE HERE）

スクリプト例を使用 - 他の問題は、新しいブックを作成し、任意のシートを追加していますあなたが必要とするそれに。この回答を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」などの名前を持つソースワークシートがないことを前提としています）