えくせるちゅんちゅん

ことりがエクセルをちゅんちゅんするブログ

VBAでパス設定を読み込む関数を自作する

今回はVBAでワークシート上に記述されたパス設定を読み込む関数を自作したので自分用のメモとして記録します。

思ったより長くなった上にガラパゴス仕様ですので、暇な方だけが御覧ください。


パスの記憶方法について

エクセルVBAで色々作っていると、別のファイルのパスを記述しなければならない場面が必ずあります。

皆さんはどのように記憶させていますか?

ちょっとしたコードならリテラルそのまま・・なんてこともあるかもしれませんが。

パスをリテラルで書いて困る場面というと、こんな時ですかね。

  • 同じパスを複数回使用する場合
  • 後からパスが変更される場合
  • モジュールを別のブックにコピーして使う場合

一般的なパスの記憶方法は、こんなところでしょうか。

  • コード中には記述しない
    • エクセルシートに記述する
    • レジストリに記録する
    • 外部ファイル(iniやxmljson)に記述する
  • コード中に記述する
    • 使用するモジュールにConstで記述する (△)
    • パスを定義する専用モジュールにPublic Constで記述する (○)

使用するモジュールに記述するのを△としているのは、処理を記述するモジュールでConstを定義してしまうと、将来モジュールをアップデートする時に修正の手間が発生するからです。

今回使うテーブルの仕様

さて、今回の目的は「エクセルシートにパスを記述する」時のパス情報の取得を行う関数の作成です。

今回使用するパス設定テーブルは次の3列で構成されています。

  • A列に何のパスか
  • B列にフォルダの絶対パス
  • C列にファイル名

この方式だとセルの書き換えで済むので、こんなメリットがありそうです。

  • VBEを起動しなくて良い
  • エクセルの強力な編集機能で手軽に変更出来る
  • VBAによる自動で書き換えが容易
  • 検証環境と本番環境でVBAコードの同一性を保持出来る

まぁ一部はトラブルの元となりやすくデメリットとも言えますが。

扱いやすいので私はこの方法が一番好きです。

今回はこの仕様を抜本的に見直します。

改修前のシステム

それではまず改修前のコードとテーブルをお見せしましょう。

ちなみにパス設定テーブルも、後々のコードも、空想上の産物なので、その点はご安心ください。

実際のコードはこれ以上の糞コードですけどね!

BadCode.bas

Option Explicit

'およそ(20モジュール、数百プロシージャ)で「Worksheets("設定").Range("B7")」のような表現を使っている。

Sub 一覧表を開く()
    Workbooks.Open Worksheets("設定").Range("B5") & Worksheets("設定").Range("C5"), ReadOnly:=True
End Sub

'テキストファイルを開いてアレコレするコードとか
Sub 日報読み込み(ymd As Date)
    Dim dr As String
    Dim fn As String
    Dim buf As String
    dr = Worksheets("設定").Range("B3")
    fn = Format(ymd, "yyyymm") & Worksheets("設定").Range("C3")

    Open dr & fn For Input As #1
    Do While Not EOF(1)
        Line Input #1, buf
        '-----
        Debug.Print buf
        '----
    Loop
    Close #1
End Sub

'number   : 6桁=平成年2桁+連番4桁
Sub 計画書を開く(number As String)
    Dim dr As String
    Dim fn As String
    Dim buf As String
    
    '\\192.168.1.123\share\hogehogesystem\planning\H31\
    dr = Worksheets("設定").Range("B6") & "H" & Left(number, 2) & "\"
    '計画書310123.xlsm
    fn = Replace(Worksheets("設定").Range("C6"), ".", number & ".")
    
    Workbooks.Open dr & fn

End Sub

'フォルダ以下のブックを連続で開いてアレコレする
'ee : 平成年度2桁
Sub 計画書連続読み込み(ee As String)
    Dim dr As String
    Dim fn As String
    Dim buf As String
    dr = Worksheets("設定").Range("B4") & "H" & ee & "\"

    fn = Dir(dr)
    Do While buf <> ""
        Workbooks.Open dr & fn
        '-----
        Debug.Print Cells(1, 1)
        '-----
        ActiveWorkbook.Close False
        buf = Dir()
    Loop
End Sub

テーブル

項目 フォルダ名 ファイル名
システムルート \\192.168.1.123\share\hogehogesystem\
社員日報データ \\192.168.1.123\share\hogehogesystem\data\ 社員.txt
月報 \\192.168.1.123\share\hogehogesystem\月報\
一覧表 \\192.168.1.123\share\hogehogesystem\ 一覧表.xls
計画書 \\192.168.1.123\share\hogehogesystem\planning\ 計画書.xlsm
社員データ \\192.168.1.123\share\database\ 社員データ.txt
パート日報データ \\192.168.1.123\share\hogehogesystem\data\ パート.txt

問題点

こんなもんでも目的の動作はしているため、利用者視点では問題ありません。

しかし設定を行う人や開発者からすると、この仕様にはすぐに思いつくだけでもこれだけの問題があります。

  • 設定シートを含むワークブックが指定されていない。
  • Worksheets("設定")が大量に出現する。
  • 同じ意味を持つ列番号BとCが大量に出現する。
  • 一行で同じ意味を持つ行番号が2回出現する。
  • コードから何のパスを読み込んでいるのか読み取れない。
  • コード中で自由にパスを改変しており、テーブルから最終的なパスが特定できない。
  • テーブルの並び順を変更出来ないため、後から追記した類似するパスが散乱する。
  • テーブルのパスがシステムの位置を基準に変化するパスなのか、独立した別のパスなのか判別できない。

これらについて簡単に解説していきます。

コードの問題

まずは下記のコードから分かる問題ですが、

Worksheets("設定").Range("B5") & Worksheets("設定").Range("C5")

設定シートを含むワークブックが指定されていない。

本当はThisWorkbookのことを指したいはずですが、省略したらActiveWorkbookになりますから間違いなく危険ですね。

Worksheets("設定")が大量に出現する。

シート名を「設定」で固定するのは許容出来るにしても、何が起こるか分かりませんからプロパティで1箇所にまとめるとか、定数を宣言すべきですね。

同じ意味を持つ列番号BとCが大量に出現する。

全体を通してB列はフォルダのパス、C列はファイルの名前と決まっているのであれば、せめて定数を宣言するべきですね。

もし設定シートではない別の場面でもRange("B10")とかを使用している場合、関係無いものまで検索にヒットしてしまいますから、誤って書き換えてしまうかもしれません。

一行で同じ意味を持つ行番号が2回出現する。

フォルダパスとファイル名は基本的にセットで使うので、行番号は変数化して1つにまとめるべきですね。

コードから何のパスを読み込んでいるのか読み取れない。

Range("B5")なんて書かれていても5行目が何のパスを示しているのか、テーブルと並べて見ないと分かりません。不便です。

コード中で自由にパスを改変しており、テーブルから最終的なパスが特定できない。

    dr = Worksheets("設定").Range("B3")
    fn = Format(ymd, "yyyymm") & Worksheets("設定").Range("C3")

例えば上記のコードではテーブルから取得したファイル名の前に年月「201801」を追記しています。

この時点でテーブルからは、最終的に求められているパスが特定出来ないため、ユーザーからすれば \\192.168.1.123\share\hogehogesystem\data\社員.txtを用意したのにエラーが出る。なんてことが起こりそうです。

当然エラー処理として「\\192.168.1.123\share\hogehogesystem\data\201801社員.txtが見つかりません。」などとエラーを出すことで何を目的としたパスか分かるかもしれませんが。どう考えても設計ミスでしょう。

テーブルの問題

次にパス設定を行う人にとっての問題です。

テーブルの並び順を変更出来ないため、後から追記した類似するパスが散乱する。

上記の表で言うと社員日報データパート日報データがそうですね。

テーブルにパス記述していくにあたって、類似するものは続けて書きたいですよね。

並び順は自由に変更出来るようにしてくれないと利便性が最悪です。

知らずに行の挿入なんてしてしまった暁には、システム全体が動作しなくなります。

テーブルのパスがシステムの位置を基準に変化する相対パスなのか、独立した別のパスなのか判別できない。

上記の表で言うと社員データ\\192.168.1.123\share\database\社員データ.txtですね。

システムの設置位置に関わらず、サーバー上のdatabaseフォルダを参照するわけですから、下手に触ってはいけないパスだということが一目見て分かるようにしないといけません。

実際には数式を使ってシステムルートと文字列をくっつけて絶対パスを生成しているんですが、テーブルの中で数式を使ったりただの定数だったりと、そんな恐ろしいテーブルになっています。

そもそもテーブルというか表ですね。

もしシステムの設置位置を変えたら、一件一件数式の妥当性をチェックしなければならず面倒です。

GetPathSettingモジュール

という訳で、ここまでの問題を解消したモジュールがこちらです。

仕様

まず次の3点のルールを定めました。

  • A列をアクセスキーとする
  • パスは相対パス絶対パスどちらでも記述出来ることとする
  • パス中の変数となる部分は[~]で記述する

コード

前提として以前書いた相対パス絶対パスに変換するGetAbsolutePathNameEx関数が必要です。

www.excel-chunchun.com

Option Explicit

Private Const SETTING_SHEET_NAME = "設定"
Private Const SYSTEM_ROOT_KEY = "システムルート"

'任意の列の設定値を取り出す
'Key:A列の値 Col:列番号1~
Private Function GetSetting(Key As String, Col As Long) As String
    '※StaticでDictionaryをキャッシュさせたほうが高速だが、
    'ループ中に記述するような関数では無いので速度は必要ないし、
    'ユーザーが変更したときに更新忘れの危険性があるためしない。
    Dim SettingSheet As Worksheet
    Set SettingSheet = ThisWorkbook.Worksheets(SETTING_SHEET_NAME)
    
    Dim Data As Variant
    Dim i As Long, j As Long
    Data = SettingSheet.UsedRange.Value
    '設定キーに重複が見つかったらシステムを完全停止させる。
    Dim Dic As Dictionary: Set Dic = New Dictionary
    For i = 2 To UBound(Data, 1)
        If Data(i, 1) <> "" Then
            If Dic.Exists(Data(i, 1)) Then
                SettingSheet.Parent.Activate
                SettingSheet.Visible = xlSheetVisible
                SettingSheet.Select
                SettingSheet.Cells(i, 1).Select
                MsgBox "設定キー[" & Data(i, 1) & "]が重複しています。"
                End
            Else
                Dim ColumnValue As Variant
                ReDim ColumnValue(1 To UBound(Data, 2))
                For j = LBound(Data, 2) To UBound(Data, 2)
                    ColumnValue(j) = Data(i, j)
                Next
                Dic.Add Data(i, 1), ColumnValue
            End If
        End If
    Next
    If Col <= UBound(Data, 2) Then
        If Dic.Exists(Key) Then
            GetSetting = Dic(Key)(Col)
        End If
    End If
End Function

'システムルートディレクトリの定義
'原則としてはThisWorkbook.Pathになるべきなので定義は不要
'どうしてもルートを変えなければならない場面があるため上書き出来るように用意した機能
Public Property Get SystemRoot() As String
    Dim fso As New FileSystemObject
    If GetFolderRelative(SYSTEM_ROOT_KEY) = "" Then
        SystemRoot = ThisWorkbook.Path & "\"
    Else
        SystemRoot = GetAbsolutePathNameEx(ThisWorkbook.Path, GetFolderRelative(SYSTEM_ROOT_KEY))
    End If
End Property

'設定に記載されたフォルダを記述された通りに返す。
'必ずしも相対パスとは限らない。
Public Function GetFolderRelative(Key As String, Optional param As Dictionary) As String
    GetFolderRelative = GetSetting(Key, 2)
    GetFolderRelative = ReplacePathParam(GetFolderRelative, param)
End Function

'設定に記載されたフォルダを絶対パスに変換して返す。
Public Function GetFolderAbsolute(Key As String, Optional param As Dictionary) As String
    GetFolderAbsolute = GetAbsolutePathNameEx(SystemRoot, GetSetting(Key, 2))
    GetFolderAbsolute = ReplacePathParam(GetFolderAbsolute, param)
End Function

'設定に記載されたファイル名を返す
Public Function GetFileName(Key As String, Optional param As Dictionary) As String
    GetFileName = GetSetting(Key, 3)
    GetFileName = ReplacePathParam(GetFileName, param)
End Function

'設定に記載されたフルパスを返す
Public Function GetFullPath(Key As String, Optional param As Dictionary) As String
    GetFullPath = GetAbsolutePathNameEx(SystemRoot, GetSetting(Key, 2)) & GetSetting(Key, 3)
    GetFullPath = ReplacePathParam(GetFullPath, param)
End Function

'パスに含まれる[~]をリストを元に置換した結果を返す
Private Function ReplacePathParam(ByVal Path As String, Optional param As Dictionary) As String
    Dim V As Variant
    If Not param Is Nothing Then
        For Each V In param.Keys
            Path = Replace(Path, "[" & V & "]", param(V))
        Next
    End If
    For Each V In Split(Path, "\")
        If V Like "*[[]*[]]*" Then
            Err.Raise 9999, "Path", "" & V & "に必要なパラメータが不足しています。"
        End If
    Next
    ReplacePathParam = Path
End Function

解説

ずいぶんと長くなってしまいました。

簡単にですが順番に解説していきます。

GetSetting関数

テーブルからデータを取り出す部分です。

次のような順で処理してます。

  1. 設定シートのデータ全部を二次元配列に格納
  2. 行ごとのデータをDictionaryでA列をキーにして格納
  3. キー重複を検知したら強制終了
  4. キーを元にして任意の列データを取り出し

呼び出すたびに設定データを読み込んでいるので、ロスが多いと感じるかもしれませんが、キャッシュすることでキャッシュ後にユーザーが書き換えた場合に意図したとおりに動作しなくなるというデメリットがありますので、今回のように速度を求められない場合は無理に高速化するより毎回読み込むほうがバグが起こりません。

Private Const SETTING_SHEET_NAME = "設定"
Private Const SYSTEM_ROOT_KEY = "システムルート"

'任意の列の設定値を取り出す
'Key:A列の値 Col:列番号1~
Private Function GetSetting(Key As String, Col As Long) As String
    '※StaticでDictionaryをキャッシュさせたほうが高速だが、
    'ループ中に記述するような関数では無いので速度は必要ないし、
    'ユーザーが変更したときに更新忘れの危険性があるためしない。
    Dim SettingSheet As Worksheet
    Set SettingSheet = ThisWorkbook.Worksheets(SETTING_SHEET_NAME)
    
    Dim Data As Variant
    Dim i As Long, j As Long
    Data = SettingSheet.UsedRange.Value
    '設定キーに重複が見つかったらシステムを完全停止させる。
    Dim Dic As Dictionary: Set Dic = New Dictionary
    For i = 2 To UBound(Data, 1)
        If Data(i, 1) <> "" Then
            If Dic.Exists(Data(i, 1)) Then
                SettingSheet.Parent.Activate
                SettingSheet.Visible = xlSheetVisible
                SettingSheet.Select
                SettingSheet.Cells(i, 1).Select
                MsgBox "設定キー[" & Data(i, 1) & "]が重複しています。"
                End
            Else
                Dim ColumnValue As Variant
                ReDim ColumnValue(1 To UBound(Data, 2))
                For j = LBound(Data, 2) To UBound(Data, 2)
                    ColumnValue(j) = Data(i, j)
                Next
                Dic.Add Data(i, 1), ColumnValue
            End If
        End If
    Next
    If Col <= UBound(Data, 2) Then
        If Dic.Exists(Key) Then
            GetSetting = Dic(Key)(Col)
        End If
    End If
End Function

SystemRootプロパティ

コメントの通りです。キーに「システムルート」と記載したパスは特別な処理をするようにしています。

'システムルートディレクトリの定義
'原則としてはThisWorkbook.Pathになるべきなので定義は不要
'どうしてもルートを変えなければならない場面があるため上書き出来るように用意した機能
Public Property Get SystemRoot() As String
    Dim fso As New FileSystemObject
    If GetFolderRelative(SYSTEM_ROOT_KEY) = "" Then
        SystemRoot = ThisWorkbook.Path & "\"
    Else
        SystemRoot = GetAbsolutePathNameEx(ThisWorkbook.Path, GetFolderRelative(SYSTEM_ROOT_KEY))
    End If
End Property

Getほにゃらら関数群

相対フォルダパス、絶対フォルダパス、ファイル名、フルパスを返す関数です。

ここで注目なのはOptional param As Dictionaryの部分で、パス設定テーブルに変数として記述した文字列を置換するためのパラメータを受け取っています。

その置換処理をしているのがこの後のReplacePathParam関数です。

'設定に記載されたフォルダを記述された通りに返す。
'必ずしも相対パスとは限らない。
Public Function GetFolderRelative(Key As String, Optional param As Dictionary) As String
    GetFolderRelative = GetSetting(Key, 2)
    GetFolderRelative = ReplacePathParam(GetFolderRelative, param)
End Function

'設定に記載されたフォルダを絶対パスに変換して返す。
Public Function GetFolderAbsolute(Key As String, Optional param As Dictionary) As String
    GetFolderAbsolute = GetAbsolutePathNameEx(SystemRoot, GetSetting(Key, 2))
    GetFolderAbsolute = ReplacePathParam(GetFolderAbsolute, param)
End Function

'設定に記載されたファイル名を返す
Public Function GetFileName(Key As String, Optional param As Dictionary) As String
    GetFileName = GetSetting(Key, 3)
    GetFileName = ReplacePathParam(GetFileName, param)
End Function

'設定に記載されたフルパスを返す
Public Function GetFullPath(Key As String, Optional param As Dictionary) As String
    GetFullPath = GetAbsolutePathNameEx(SystemRoot, GetSetting(Key, 2)) & GetSetting(Key, 3)
    GetFullPath = ReplacePathParam(GetFullPath, param)
End Function

ReplacePathParam関数

パスに含まれる[~]をパラメータリストを元に置換する関数です。

パスを解析してパラメータが足りていないと、実行時エラーを起こします。

エラーメッセージは一目見ただけで何のパラメータが足りていないのか分かるようにしたつもりです。

'パスに含まれる[~]をリストを元に置換した結果を返す
Private Function ReplacePathParam(ByVal Path As String, Optional param As Dictionary) As String
    Dim V As Variant
    If Not param Is Nothing Then
        For Each V In param.Keys
            Path = Replace(Path, "[" & V & "]", param(V))
        Next
    End If
    For Each V In Split(Path, "\")
        If V Like "*[[]*[]]*" Then
            Err.Raise 9999, "Path", "" & V & "に必要なパラメータが不足しています。"
        End If
    Next
    ReplacePathParam = Path
End Function

使用方法

テーブル

テーブルは次のように書き換えました。

システム配下のパスは相対パスに、外部のデータベースは絶対パスで記述しています。

先に記載したとおり相対パスにしたものは、システムルートディレクトリが基準となります。

また、並び順は自由に変更してOKです。

項目 フォルダ名 ファイル名
システムルート .\
社員日報データ .\data\ [yyyymm]社員.txt
月報 .\月報\H[ee]\
一覧表 .\ 一覧表.xls
計画書 .\planning\H[ee]\ 計画書[######].xlsm
社員データ \\192.168.1.123\share\database\ 社員データ.txt
パート日報データ .\data\ [yyyymm]パート.txt

例1

一番シンプルな例はこんな感じです。

Sub 一覧表()
    Workbooks.Open GetFullPath("一覧表"), ReadOnly:=True
End Sub

GetFullPathにA列のキーを渡しただけでファイルのフルパスが帰ってきます。

超わかりやすいよね・・?

例2

パラメータを必要とするタイプだとこんな感じです。

'number   : 6桁=平成年2桁+連番4桁
Sub 計画書を開く(number As String)
    Dim fn As String
    Dim param As Dictionary
    
    Set param = New Dictionary
    param.Add "ee", Left(number, 2)
    param.Add "######", number
    fn = GetFullPath("計画書", param)
    
    '以下略
    Debug.Print fn
End Sub

先にパラメータをDictionaryで登録しておいて渡すだけです。

例3

あえてパラメータを付けずに実行してみます。

Sub test_NG()
    Debug.Print GetFolderAbsolute("計画書")
End Sub

このようなエラーが出ます。

実行時エラー'9999':
H[ee]に必要なパラメータが不足しています。

まとめ

思った以上に長くなってしまいました。

とりあえずこれで設定テーブルの読み込み機能は完成です。

クラス化しても良いかもしれませんね。

もし同じようなことをしたい人は参考にしていただければと思います。

以上


何か御座いましたらコメント欄、またはTwitterからどうぞ♪

それではまた来週♪ ちゅんちゅん(・8・)

プライバシーポリシー