Help us understand the problem. What is going on with this article?

Excel ファイルパス、フォルダパスを選択しセルに格納する参照ボタン

More than 3 years have passed since last update.

Excelでツールを作成する時、必ずと言っていい程必要になるフォルダ選択ダイアログとファイル選択ダイアログ。
存在チェックとかダイアログ初期値設定とか意外と面倒なのでメモ。

Excelシート設定

  • セル名を指定する。
    例)cellFolderPath, cellFilePath
    image1.png
    image2.png

  • 参照ボタンの設定は下記のような感じで
    image3.png

VBE参照設定

  • 「Microsoft Scripting Runtime」を参照設定する。
     選択肢にない場合は「参照」ボタンから
     C:\Windows\System32\scrrun.dll
    を選択する。
    image4.png

フォルダ選択ダイアログマクロ

  • ざっくり仕様
  • セルにパスがある場合、参照ぼたん押下時はその場所を開く。
  • セルにパスがない場合、または、存在しないパスの場合はブックの場所を開く。

  • ソース

フォルダ選択Dialog.vba
' 検索対象フォルダの参照ボタンのクリックイベント
Private Sub btnChoiceFolder_Click()
    Dim objFS           As New FileSystemObject
    Dim strPath         As String
    Dim ofdFolderDlg    As Office.FileDialog

    strPath = Range("cellFolderPath").Value

    ' 初期フォルダの設定
    If Len(strPath) > 0 Then
        ' 末尾の"\"削除
        If Right(strPath, 1) = "\" Then
            strPath = Left(strPath, Len(strPath) - 1)
        End If

        ' フォルダ存在チェック
        If Not objFS.FolderExists(strPath) Then
            strPath = ThisWorkbook.Path
        End If
        Set objFS = Nothing
    Else
        strPath = ThisWorkbook.Path
    End If

    ' フォルダ選択ダイアログ設定
    Set ofdFolderDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With ofdFolderDlg
        ' 表示するアイコンの大きさを指定
        .InitialView = msoFileDialogViewDetails
        ' フォルダ初期位置
        .InitialFileName = strPath & "\"
        ' 複数選択不可
        .AllowMultiSelect = False
    End With

    ' フォルダ選択ダイアログ表示
    If ofdFolderDlg.Show() = -1 Then
        ' フォルダパス設定
        Range("cellFolderPath").Value = ofdFolderDlg.SelectedItems(1)
    End If

    Set ofdFolderDlg = Nothing
    Exit Sub
End Sub
  • 結果
    こんな感じ image5.png

ファイル選択ダイアログマクロ

  • ざっくり仕様
  • セルにファイルパスがある場合、参照ぼたん押下時はその場所を開く。ファイル名も選択状態にする。
  • セルにパスがない場合、または、存在しないパスの場合はブックの場所を開く。ファイル名はなしの状態。
  • セルにフォルダパスが指定してある場合、そのフォルダを開く。ファイル名はなしの状態。

  • ソース

ファイル選択Dialog.vba
Private Sub btnChoiceFile_Click()
    Dim objFS           As New FileSystemObject
    Dim strPath         As String
    Dim strFile         As String
    Dim strFolder       As String
    Dim ofdFolderDlg    As Office.FileDialog

    strPath = Range("cellFilePath").Value

    ' 初期パスの設定
    If Len(strPath) > 0 Then
        ' 末尾の"\"削除
        If Right(strPath, 1) = "\" Then
            strPath = Left(strPath, Len(strPath) - 1)
        End If

        ' ファイルが存在
        If objFS.FileExists(strPath) Then
            ' ファイル名のみ取得
            strFile = objFS.GetFileName(strPath)
            ' フォルダパスのみ取得
            strFolder = objFS.GetParentFolderName(strPath)
        ' ファイルが存在しない
        Else
            ' フォルダが存在
            If objFS.FolderExists(strPath) Then
                strFile = ""
                strFolder = strPath
            ' フォルダが存在しない
            Else
                ' ファイル名のみ取得
                strFile = objFS.GetFileName(strPath)
                ' 親フォルダを取得
                strFolder = objFS.GetParentFolderName(strPath)
                ' 親フォルダが存在しない
                If Not objFS.FolderExists(strFolder) Then
                    strFolder = ThisWorkbook.Path
                End If
            End If
        End If
        Set objFS = Nothing
    Else
        strFolder = ThisWorkbook.Path
        strFile = ""
    End If

    ' ファイル選択ダイアログ設定
    Set ofdFileDlg = Application.FileDialog(msoFileDialogFilePicker)
    With ofdFileDlg
        .ButtonName = "選択"
        '「ファイルの種類」をクリア
        .Filters.Clear
        '「ファイルの種類」を登録
        .Filters.Add "CSVファイル", "*.?sv", 1
        .Filters.Add "全ファイル", "*.*", 2

        ' 初期フォルダ
        .InitialFileName = strFolder & "\" & strFile
        ' 複数選択不可
        .AllowMultiSelect = False
        '表示するアイコンの大きさを指定
        .InitialView = msoFileDialogViewDetails
    End With

    ' フォルダ選択ダイアログ表示
    If ofdFileDlg.Show() = -1 Then
        ' フォルダパス設定
        Range("cellFilePath").Value = ofdFileDlg.SelectedItems(1)
    End If

    Set ofdFileDlg = Nothing
    Exit Sub
End Sub
  • 結果
    こんな感じ image6.png
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
No comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
ユーザーは見つかりませんでした