【エクセルVBA】ボタンからパラメータを与えてファイルを選択してパスをセルへ出力する方法

はじめに

エクセルVBAでよく以下の処理を実装することがあると思います。

• ボタンからメソッドを実行
• ウィンドウからファイルを選択する
• 選択したファイルのフルパスをセルへ出力する

複数のファイルを選択させるマクロの場合、以下のような値が可変値になります。

• 出力するシート
• 出力するセル
• ファイル選択ウィンドウのタイトル
• ファイル選択ウィンドウで表示する拡張子

これらの値をメソッドを呼び出すボタンに応じて変更できるように、ボタンからメソッドにパラメータを渡して実行する例を紹介します。

ボタンから引数を与える

以下のようなメソッドを作成しておきます。

Sub WriteSelectFilePathInCell(ByVal arg As String)
    Debug.Print arg
End Sub

リボンの「開発」タブの「挿入」から「ボタン（フォームコントロール）」を選択してボタンを挿入します。

そのまま「OK」を押下します。

作成したボタンを右クリックして「マクロの登録」を選択して、表示されるウィンドウの「マクロ名」に以下を入力します。

test.xlsm!'WriteSelectFilePathInCell "拡張子,タイトル,デフォルトパス,入力セル,入力シート"'

※ブック名「test.xlsm」は適宜変更してください。

これで、ボタンを押すと引数の「拡張子,タイトル,デフォルトパス,入力セル,入力シート」が出力されます。

引数の情報を使ってダイアログを表示させる

メソッド以下のように変更します。

Sub WriteSelectFilePathInCell(ByVal arg As String)

    'ボタンから受け取った引数をカンマ区切りで配列に格納する。
    Dim argArr() As String
    argArr = Split(arg, ",")

    'デフォルトのパスが決まっていないので、マクロと同じフォルダに変更する。
    argArr(2) = ThisWorkbook.path

    'ダイアログを表示してファイルを選択させる。
    Dim selectFileName As String
    selectFileName = WriteSelectFilePath(argArr(0), argArr(1), argArr(2), argArr(3), argArr(4))

End Sub


'ファイルをダイアログから選択して、フルパスをセルに入力する
'
'@param fileFilter ダイアログで表示する拡張子
'@param titleMessage ダイアログのタイトル
'@param defaultPath ダイアログで最初に表示されるパス
'@param shName 出力シート
'@param outputCell 選択したファイルのパスを入力するセル
'@return 選択したファイルのパス（キャンセル時は"False"を返す）
Function WriteSelectFilePath(ByVal fileFilter As String, ByVal titleMessage As String, ByVal defaultPath As String, ByVal shName As String, ByVal outputCell As String)

    Dim path As String
    path = GetSelectFileFullPath(titleMessage, fileFilter, defaultPath)

    If path <> "False" Then
        ThisWorkbook.Worksheets(shName).Range(outputCell) = path
    Else
        ThisWorkbook.Worksheets(shName).Range(outputCell) = ""
    End If

    WriteSelectFilePath = path

End Function


'ダイアログからファイルを1つ選択する。
'選択したファイルのフルパスを戻り値とする。
'
'@param(Optional) dialogTitle　ダイアログのタイトル
'@param(Optional) fileFilter ダイアログに表示するファイルの拡張子
'@return openFileFullPaht 選択したファイルのフルパス。キャンセルを選択した時は「False」(String型)。
Function GetSelectFileFullPath(Optional dialogTitle As String = "ファイルを選択してください。", Optional fileFilter As String = "*", Optional defaultPath As String = "") As String

    '現在のカレントディレクトリのバックアップを取得する
    Dim currentFolderPath As String
    currentFolderPath = CurDir

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    'カレントディレクトリの変更
    '省略又はフォルダが存在しない場合は、マクロのフォルダをデフォルトにする
    If defaultPath = "" Or Not fso.FolderExists(defaultPath) Then
        CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.path & "\"
    Else
        CreateObject("WScript.Shell").CurrentDirectory = defaultPath
    End If

    'フィルタに使用する文字列を作成
    Dim argFileFilter As String
    argFileFilter = ",*." + fileFilter

    'ダイアログの表示
    GetSelectFileFullPath = Application.GetOpenFilename(Title:=dialogTitle, fileFilter:=argFileFilter)

    'カレントディレクトリの戻し
    CreateObject("WScript.Shell").CurrentDirectory = currentFolderPath

End Function

ボタンの引数を以下のように変更します。

test.xlsm!'WriteSelectFilePathInCell "txt,タイトル,デフォルトパス,B2,Sheet1"'

ボタンから渡した文字列をカンマで分割して、それぞれのパラメータとして使用します。

ボタンを押下してマクロを実行すると、タイトルと表示されるファイルの拡張子が引数で指定した値になっています。
今回はデフォルトパスをエクセルファイルと同じパスにしていますが、その部分をコメントアウトすれば引数のデフォルトパスで指定したパスが表示されます。

選択したファイルのフルパスがシート「Sheet1」のセル「B2」へ出力されます。こちらも引数で指定した値です。

列挙型

上記のコードでほぼ完成ですが、添字をベタ書きにしているので列挙型に変更します。

'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
'【列挙体】ファイル選択時の配列の要素に対応する値
'━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━
Enum fileSelectArray
    fileFilter = 0
    Title = 1
    defaultPath = 2
    outputCell = 3
    shName = 4
End Enum


Sub WriteSelectFilePathInCell(ByVal arg As String)

    'ボタンから受け取った引数をカンマ区切りで配列に格納する。
    Dim argArr() As String
    argArr = Split(arg, ",")

    'デフォルトのパスが決まっていないので、」マクロと同じフォルダに変更する。
    argArr(fileSelectArray.defaultPath) = ThisWorkbook.path

    'ダイアログを表示してファイルを選択させる。
    Dim selectFileName As String
    selectFileName = WriteSelectFilePath(argArr(fileSelectArray.fileFilter), _
                                                                    argArr(fileSelectArray.Title), _
                                                                    argArr(fileSelectArray.defaultPath), _
                                                                    argArr(fileSelectArray.shName), _
                                                                    argArr(fileSelectArray.outputCell))

End Sub


'ファイルをダイアログから選択して、フルパスをセルに入力する
'
'@param fileFilter ダイアログで表示する拡張子
'@param titleMessage ダイアログのタイトル
'@param defaultPath ダイアログで最初に表示されるパス
'@param shName 出力シート
'@param outputCell 選択したファイルのパスを入力するセル
'@return 選択したファイルのパス（キャンセル時は"False"を返す）
Function WriteSelectFilePath(ByVal fileFilter As String, ByVal titleMessage As String, ByVal defaultPath As String, ByVal shName As String, ByVal outputCell As String)

    Dim path As String
    path = GetSelectFileFullPath(titleMessage, fileFilter, defaultPath)

    If path <> "False" Then
        ThisWorkbook.Worksheets(shName).Range(outputCell) = path
    Else
        ThisWorkbook.Worksheets(shName).Range(outputCell) = ""
    End If

    WriteSelectFilePath = path

End Function


'ダイアログからファイルを1つ選択する。
'選択したファイルのフルパスを戻り値とする。
'
'@param(Optional) dialogTitle　ダイアログのタイトル
'@param(Optional) fileFilter ダイアログに表示するファイルの拡張子
'@return openFileFullPaht 選択したファイルのフルパス。キャンセルを選択した時は「False」(String型)。
Function GetSelectFileFullPath(Optional dialogTitle As String = "ファイルを選択してください。", Optional fileFilter As String = "*", Optional defaultPath As String = "") As String

    '現在のカレントディレクトリのバックアップを取得する
    Dim currentFolderPath As String
    currentFolderPath = CurDir

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    'カレントディレクトリの変更
    '省略又はフォルダが存在しない場合は、マクロのフォルダをデフォルトにする
    If defaultPath = "" Or Not fso.FolderExists(defaultPath) Then
        CreateObject("WScript.Shell").CurrentDirectory = ThisWorkbook.path & "\"
    Else
        CreateObject("WScript.Shell").CurrentDirectory = defaultPath
    End If

    'フィルタに使用する文字列を作成
    Dim argFileFilter As String
    argFileFilter = ",*." + fileFilter

    'ダイアログの表示
    GetSelectFileFullPath = Application.GetOpenFilename(Title:=dialogTitle, fileFilter:=argFileFilter)

    'カレントディレクトリの戻し
    CreateObject("WScript.Shell").CurrentDirectory = currentFolderPath

End Function

終わり

駆け足で作成した部分もあるので、少しずつ追記していきたいと思います。
アドベントカレンダーの記事を当日に書き出すのはよくないですね。。

明日は@mikaka360さんの記事です。