fd-ricky

パソコン関係のメモが多め

ExcelのVBAで設定シート

背景

シートに書いてある設定値を読み込んでVBAで使用したい......そんな状況が頻繁に起こるため、テンプレート化する。
Sheet Objectにコードを書くタイプとClassにするタイプの両方を記す。

準備

シートを作成して以下のようなテーブルを作成する。テーブルの名前はConfigとする。
Config以外にしたら、後のコード内のCONFIG_TABLE_NAMEを変更する。 シート名とシートオブジェクト名は何でも良い。 今回はシート名をConfig, オブジェクト名をConfigSheetとした。

Sheet Objectにコードを書くタイプ

コード

ConfigSheetに以下コードを張り付ける。

' ConfigSheet

Option Explicit

Private Config As Collection ' 参照設定をしなくて済むようにDictionaryの代わりにCollectionを使用
Private Const CONFIG_TABLE_NAME As String = "Config"
Private Const KEY_COLUMN_NUM As Long = 1
Private Const VALUE_COLUMN_NUM As Long = 2

' Config tableの内容をDictionaryに読み込む関数
Public Sub LoadConfig()
    Set Config = New Collection
    Dim ListRow As ListRow
    For Each ListRow In Me.ListObjects(CONFIG_TABLE_NAME).ListRows
        Config.Add ListRow.Range(VALUE_COLUMN_NUM).Value, ListRow.Range(KEY_COLUMN_NUM).Value
    Next
End Sub

' Config tableのKeyに応じたValueを返す関数
Public Function GetConfig(Key As String) As Variant
    ' GetConfig初回呼び出しの場合、LoadConfigしてからGetConfigするための処理
    If Config Is Nothing Then Call LoadConfig
    ' Keyが見つからなかったらエラー
    GetConfig = Config.Item(Key)
End Function

呼び出し側コードの例

' Module1

Option Explicit

Sub Test()
    Debug.Print ConfigSheet.GetConfig("Key1")
End Sub

Classにするタイプ

コード

' ConfigTableReader
Option Explicit

Private Config As Collection
Private Const KEY_COLUMN_NUM As Long = 1
Private Const VALUE_COLUMN_NUM As Long = 2

Public Function ReadConfig(Table As ListObject) As ConfigTableReader
    Set Config = New Collection
    Dim ListRow As ListRow
    For Each ListRow In Table.ListRows
        Config.Add ListRow.Range(VALUE_COLUMN_NUM).Value, ListRow.Range(KEY_COLUMN_NUM).Value
    Next
    Set ReadConfig = Me
End Function

Public Function GetConfig(Key As String) As Variant
    GetConfig = Config.Item(Key)
End Function

呼び出し側コードの例
Configだらけで気持ち悪い......

' Module1
Sub Test()
    Dim CTR As ConfigTableReader: Set CTR = New ConfigTableReader
    Debug.Print CTR.ReadConfig(ConfigSheet.ListObjects("Config")).GetConfig("Key6")
End Sub

使い分け

シートに直接書く

  • メリット
    • クラスモジュールが増えない
    • Dim, Newが要らない
  • デメリット
    • シートのメンバーが増えてしまう（なんとなく気持ち悪い）

Classにするタイプ

  • メリット
    • オーソドックスなやり方
    • （やるかは別として）同一シートに複数の設定テーブルを作成してもOK
  • デメリット
    • 設定を読み込むだけのクラスができてしまう
    • Dim, Newめんどくさい

PowerShellでファイルパスをルートに向かって存在確認する

背景

Outlookとかにファイルパスがリンクとして張り付けられていることがある。 送信後にフォルダ構成を変更すると、エクスプローラーでアクセスしたときにエラーが出る（当たり前）。

その場合、生きているパスの中で最も深いパスが知りたくなる。 そういう場合に使えそうなPowerShellのコードを乗せとく。 自分が使いやすいように、クリップボードから読み取り既定のプログラム（エクスプローラー）で開くようにする。

注意点

コード

もっといい書き方ないのかな？

function Open-LivingFilePath {
    # クリップボードからファイルパスを読み込む。
    # たまにダブルクォーテーションが付いていることがあるから消す。
    $P = (Get-Clipboard) -replace '"', ''

    # ファイルパスに含まれる`\`の数だけループする。
    # 無限ループだとちょっと怖いから。
    1..$P.Split("\").Length | % {
        # パスが存在したらそのパスを返してループを抜ける
        if (Test-Path $P) {
            $P
            break
        }
        # パスが存在しなかったら親の存在確認する
        else {
            $P = Split-Path $P
        }
    # エクスプローラーで開く
    } | Invoke-Item
}

使い方

"C:\Users\XXXXX\aaa\bbb\ccc.ddd" | scb
Open-LivingFilePath
# エクスプローラーで`C:\Users`が開かれる

この関数を$PROFILEでSet-Aliasしとけば楽ちん♪

VBAで全て検索と同等の関数作った

VBA Excel

作るきっかけ

  • FindからのFindNextの処理を毎回検索して書き直すのがめんどくさい
  • メインの処理にDo Loopが入って見にくい

使用上の注意点

  • Raiseするエラー番号がテキトー
  • RangeのCollectionだから検索対象のブックを閉じると参照できなくなる

全て検索する関数

とりあえず書いたけど、もっとスマートにできそう。

Public Function FindAll(ByRef What As String, ByRef Scope As Variant) As Collection
    ' 検索と置換の[全て検索(I)]に近い関数
    '
    ' Args:
    '       What (String): 検索対象文字列。 Cells.[Find|FindNext]に渡すWhat。
    '       Scope (Workbook|Worksheet): 検索範囲を示す。渡されたオブジェクトの全体を検索
    '
    ' Returns:
    '       Result: (Collection): 検索にヒットしたRangeのCollection
    '
    
    ' Scopeの型判定
    Dim TargetSheets As Object
    Select Case TypeName(Scope)
        Case "Workbook"
            Set TargetSheets = Scope.Worksheets
        Case "Worksheet"
            Set TargetSheets = New Collection
            TargetSheets.Add Scope
        Case Else
            Err.Raise 999, Scope, "Scopeの型はWorkbookかWorksheetにして下さい。"
    End Select
    ' Return用Collection
    Dim Result As Collection: Set Result = New Collection
    ' 検索結果の一時格納変数
    Dim FoundCell1 As Range, FoundCell2 As Range
    ' ループ用Worksheet
    Dim Ws As Worksheet
    For Each Ws In TargetSheets
        ' 最初の検索
        Set FoundCell1 = Ws.Cells.Find(What:=What, LookIn:=xlValues, LookAt:=xlPart)
        ' 検索結果が無ければ次のシートに
        If FoundCell1 Is Nothing Then GoTo NextWs
        ' 検索結果をCollectionに格納
        Result.Add FoundCell1
        ' シート内を複数検索するためのループ
        Do
            ' 次のセルを検索
            Set FoundCell2 = Ws.Cells.FindNext(After:=Result(Result.Count))
            ' ヒットしたセル番地と最初に検索したセルの番地が同じだったら次のシートに
            If FoundCell1.Address(external:=True) = FoundCell2.Address(external:=True) Then Exit Do
            ' 検索結果をCollectionに格納
            Result.Add FoundCell2
        Loop
NextWs: ' 他言語のContinue代わり
    Next
    Set FindAll = Result
End Function

使い方

Scopeに検索対象のオブジェクトを渡す。

Sub Test()
    Dim FoundCells As Collection, FoundCell As Range
    
    ' シート内全検索
    Set FoundCells = FindAll("A", Sheet1)
    For Each FoundCell In FoundCells
        Debug.Print FoundCell.Address(external:=True); vbTab; FoundCell.Value
    Next
    
    ' ブック内全検索
    Set FoundCells = FindAll("A", ThisWorkbook)
    For Each FoundCell In FoundCells
        Debug.Print FoundCell.Address(external:=True); vbTab; FoundCell.Value
    Next
End Sub

イミディエイトウィンドウの出力

[FindAll.xlsm]Sheet1!$B$2    A
[FindAll.xlsm]Sheet1!$C$5    ASC
[FindAll.xlsm]Sheet1!$B$6    AB
[FindAll.xlsm]Sheet1!$B$7    aaA
[FindAll.xlsm]Sheet1!$B$2    A
[FindAll.xlsm]Sheet1!$C$5    ASC
[FindAll.xlsm]Sheet1!$B$6    AB
[FindAll.xlsm]Sheet1!$B$7    aaA
[FindAll.xlsm]Sheet2!$B$2    AC
[FindAll.xlsm]Sheet2!$C$4    AD
[FindAll.xlsm]Sheet2!$B$6    AV