HOME > 即効テクニック > Excel VBA > ファイル操作関連のテクニック > 保存先フォルダを作成してブックを保存する(複数階層のフォルダ)

保存先フォルダを作成してブックを保存する(複数階層のフォルダ)|Excel VBA

ファイル操作関連のテクニック

保存先フォルダを作成してブックを保存する(複数階層のフォルダ)

(Excel 2000/2002/2003/2007/2010)

ブックに名前を付けて保存するには、SaveAsメソッドを使います。
次のコードは、アクティブブックをC:\WorkフォルダにBook1という名前で保存します。

 Sub Sample1()
    ActiveWorkbook.SaveAs "C:\Work\Book1.xls"
End Sub

このとき、C:\Workフォルダが存在しないとエラーになります。
ブックに名前を付けて保存するときは、保存先のフォルダが存在するかどうかを事前に確認した方が安全です。

フォルダが存在するかどうかはDir関数でも調べることもできますが、ここではFileSystemObjectを使って確認してみましょう。

Sub Sample2()
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists("C:\Work") Then
            MsgBox "存在します"
        Else
            MsgBox "存在しません"
        End If
    End With
End Sub

存在した場合は安心してSaveAsメソッドを実行できますが、もし存在しなかったら、フォルダを作成しなければなりません。
フォルダの作成には、FileSystemObjectのCreateFolderメソッドを使います。

Sub Sample3()
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists("C:\Work") Then .CreateFolder "C:\Work"
    End With
    ActiveWorkbook.SaveAs "C:\Work\Book1.xls"
End Sub

このように、保存先フォルダの階層が浅い場合は、対応も簡単です。
では、保存先フォルダがC:\Work\2012\Quater1だった場合はどうでしょう。
先のように、FileSystemObjectを使えば、フォルダの存在は確認できます。

Sub Sample4()
    With CreateObject("Scripting.FileSystemObject")
        If .FolderExists("C:\Work\2012\Quater1") Then
            MsgBox "存在します"
        Else
            MsgBox "存在しません"
        End If
    End With
End Sub

存在しない場合、C:\Work\2012\Quater1フォルダが存在しないのは明らかですが、もうひとつ上位のC:\Work\2012フォルダも存在しないのか、あるいは、そもそもC:\Workフォルダが存在しないのかはわかりません。
もし、C:\Work\2012フォルダが存在しない場合は、CreateFolderメソッドでC:\Work\2012\Quater1フォルダを作成しようとすると失敗します。存在しないC:\Work\2012フォルダに、新しいフォルダを作ることはできないからです。

このように深い階層のフォルダを作成するには、パスのどこまで存在するかを調べなければなりません。
フォルダの階層はさまざまですから、汎用的な対応をしたいのなら、再帰的に上位フォルダの存在を確認しなければなりません。これは、少々やっかいです。

そんなときはWindows APIの出番です。
SHCreateDirectoryExを使うと、深い階層であっても指定したフォルダを作成できます。

Declare Function SHCreateDirectoryEx Lib "shell32" Alias _
                                "SHCreateDirectoryExA" ( _
                                      ByVal hwnd As Long, _
                                ByVal pszPath As String, _
                                ByVal psa As Long) As Long

Sub Sample5()
    Dim TargetPath As String, rc As Long
    
    TargetPath = "C:\Work\2012\Quater1"
        
    With CreateObject("Scripting.FileSystemObject")
        If Not .FolderExists(TargetPath) Then
            rc = SHCreateDirectoryEx(0&, TargetPath, 0&)
        End If
    End With
    
    If rc <> 0 Then
        MsgBox "フォルダの作成に失敗しました"
    Else
        ActiveWorkbook.SaveAs TargetPath & "\Book1.xls"
    End If
End Sub

SHCreateDirectoryExは、フォルダの作成に成功すると0を返します。

作成に失敗したときは、エラーの状況に応じて戻り値を返します。
たとえば、作成しようとしている C:\Work\2012\Quater1 が既に存在していると、エラーコード 183(ERROR_ALREADY_EXISTS)を返し、指定したフォルダパスが空の文字列だった場合は、エラーコード 161(ERROR_BAD_PATHNAME)を返します。
また、"O:\Work" のように存在しないドライブのフォルダを指定すると「指定されたパスが見つかりません」とメッセージを表示し、エラーコード 1223(ERROR_CANCELLED)を返します。

●補足●

複数階層のフォルダを作成するAPI関数には、MakeSureDirectoryPathExistsもあります。
MakeSureDirectoryPathExistsの戻り値はBoolean型で、成功するとTure、失敗するとFalseを返します。作成しようとしている C:\Work\2012\Quater1 が既に存在していても、Trueを返します。
ただし、フォルダパスの末尾に「\」が必要な点に注意してください。

Private Declare Function MakeSureDirectoryPathExists _
  Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Sub Sample6()
    Dim TargetPath As String
    
    TargetPath = "C:\Work\2012\Quater1\"
    
    If MakeSureDirectoryPathExists(TargetPath) Then
        ActiveWorkbook.SaveAs TargetPath & "Book1.xls"
    Else
        MsgBox "フォルダの作成に失敗しました"
    End If
End Sub