Excelのあれこれ ~ 全ファイル検索マクロ

前置き

指定フォルダ下にある全てのExcelファイルの、すべてのシートに対して、キーワード検索するマクロを書いてみました。

※本記事のマクロは、Excel2010で動作確認しました。

作戦

  • 汎用的な関数はutilsモジュールへ置き、uXxxYyyのような名前にする
  • 1つのシート内を検索する関数を書く
  • 1つのブック内の全シートを検索する関数を書く
  • 図形内のテキストも検索対象とする
  • フォルダ階層を再帰的に走査する関数を書く
  • 検索関数や走査関数が汎用的になるように、アプリ固有の処理はデリゲート関数に委譲する
  • Stringには文字数制限があるので、検索結果はフォームのエディットボックスに格納する

検索

まずは、1シート内の検索です。Range.Find()を使いますが、ちょっとクセがあるので面倒です。

1シート検索(utils.bas)
'シート内検索。
'キャンセルされたらFalseを返す。
'マッチしたら、dFindKeywordOnMatchRange()やdFindKeywordOnMatchShape()をコールバックする。
'これらの関数は、どっかで定義しといて!!
Public Function uFindKeyword(sh As Worksheet, kw As String, Optional shape As Boolean = True) As Boolean
  uFindKeyword = True
  
  Dim lastCell As Range
  Set lastCell = sh.Range("A1").SpecialCells(xlCellTypeLastCell)
  '検索対象レンジ。
  'Set target = sh.Cellsなどとすると、結合セル内の文字列がうまく検索できないので注意。
  Dim target As Range
  Set target = sh.Range("A1:" & lastCell.MergeArea.Address)
  
  '検索開始。
  'Findのafter引数にlastCellを指定すると、セルA1から検索することになるね。
  Dim match As Range
  Set match = target.Find(kw, lastCell, xlValues, xlPart, xlByColumns, xlNext, False, False)
  If Not match Is Nothing Then
    Dim firstMatch As Range
    Set firstMatch = match
    Do
      If Not dFindKeywordOnMatchRange(sh, kw, match) Then '継続しない?
        uFindKeyword = False
        Exit Function
      End If
      Set match = target.FindNext(match)
      If match Is Nothing Then      'マッチなし? そんなはずないけどね。
        Exit Do
      End If
      If match.MergeArea.Address = firstMatch.MergeArea.Address Then  '一巡した?
        Exit Do
      End If
    Loop
  End If

  '図形内のテキストも検索。
  If Not shape Then
    Exit Function
  End If
  Dim s As shape
  For Each s In sh.Shapes
    Dim text As String
    If s.Type = msoGroup Then       'グループ化されてる?
      Dim i As Integer
      For i = 1 To s.GroupItems.count
        Dim item As shape
        Set item = s.GroupItems.item(i)
        text = textFromShape(item)
        If InStr(text, kw) > 0 Then
          If Not dFindKeywordOnMatchShape(sh, kw, item, text) Then '継続しない?
            uFindKeyword = False
            Exit Function
          End If
        End If
      Next
    Else                            'グループ化されてない。
      text = textFromShape(s)
      If InStr(text, kw) > 0 Then
        If Not dFindKeywordOnMatchShape(sh, kw, s, text) Then '継続しない?
          uFindKeyword = False
          Exit Function
        End If
      End If
    End If
  Next

End Function

dFindKeywordOnMatchRange()とdFindKeywordOnMatchShape()はデリゲート関数です。後述します。

textFromShape()は、図形内のテキストを取り出す関数で、utils.bas内にPrivateで定義してあります。正しい取り出し方が良く分からないので、トライ&エラーで、ダメなら諦めるって感じです。

ヘルパ関数(utils.bas)
'図形のテキストを取り出す。
Private Function textFromShape(s As shape) As String
  textFromShape = ""
  
  Dim text As String
  text = vbNullString     'Null値で初期化。""とは異なり、StrPtr(vbNullString)は0を返す。

  '図形の種類によって、取り出し方が違う(というか、取り出せない場合がある)。
  'トライ&エラーでいく。
  On Error Resume Next
  text = s.DrawingObject.Characters.text
  If StrPtr(text) <> 0 Then   'ちゃんと取れた?
    textFromShape = text
    Exit Function
  End If
  text = s.TextFrame.Characters.text
  If StrPtr(text) <> 0 Then   'ちゃんと取れた?
    textFromShape = text
    Exit Function
  End If
  On Error GoTo 0
  
End Function

次は全シート検索です。1シート検索を繰り返すだけです。

全シート検索(utils.bas)
'ブック内検索。
'キャンセルされたらFalseを返す。
'uFindKeyword()も参照。
Public Function uFindKeywordInBook(wb As Workbook, kw As String, Optional shape As Boolean = True) As Boolean
  uFindKeywordInBook = True
  
  Dim sh As Worksheet
  For Each sh In wb.Worksheets
    sh.Activate
    If Not uFindKeyword(sh, kw, shape) Then
      uFindKeywordInBook = False
      Exit Function
    End If
  Next
End Function

フォルダの走査

フォルダを走査するには、Dir()を使います。これも、なかなか手強い関数です。

フォルダ走査(utils.bas)
'フォルダ内のファイルを走査する。
'キャンセルされたらFalseを返す。
'走査対象フォルダに対して、dTraverseFoldersOnFolder()をコールバックする。
'見つけたファイルに対して、dTraverseFoldersOnFile()をコールバックする。
'これらの関数は、どっかで定義しといて!!
Public Function uTraverseFolders(path As String, Optional filter As String = "*.*", Optional subFolder As Boolean = True) As Boolean
  uTraverseFolders = True
  
  path = uPathWithSeparator(path)

  If Not dTraverseFoldersOnFolder(path) Then   '継続しない?
    uTraverseFolders = False
    Exit Function
  End If

  '当該フォルダ直下の走査。
  '走査しながらデリゲートを呼ぶと、デリゲートの中で何か複雑なことを
  'されたときに、走査が途切れる可能性がある。
  'そこで、まずファイル一覧をfs配列に格納してから、順にデリゲートを呼ぶ。
  Const CLUSTER_SIZE As Integer = 10
  Dim fs() As String              'ファイル一覧。
  ReDim fs(0 To CLUSTER_SIZE - 1) '初期サイズ(足りなければ再度ReDimする)。
  Dim ix As Integer
  ix = 0
  fs(ix) = Dir(path & filter, vbNormal)
  Do While fs(ix) <> ""
    ix = ix + 1
    If ix Mod CLUSTER_SIZE = 0 Then
      ReDim Preserve fs(0 To UBound(fs) + CLUSTER_SIZE)
    End If
    fs(ix) = Dir
  Loop

  'デリゲートへ委譲。
  Dim num As Integer
  num = ix
  For ix = 0 To num - 1
    If Not dTraverseFoldersOnFile(path, fs(ix)) Then   '継続しない?
      uTraverseFolders = False
      Exit Function
    End If
  Next ix
  
  If Not subFolder Then   'サブフォルダは走査しない?
    Exit Function
  End If

  'サブフォルダの走査。
  'Dir()には落とし穴があるので注意。
  '  ・ネストに耐えられない(つまりDirしながらの再帰は不可)
  '  ・属性をvbDirectoryに絞っても、普通のファイルがマッチしてしまう
  Dim ds() As String                'フォルダ一覧。
  ReDim ds(0 To CLUSTER_SIZE - 1)   '初期サイズ(足りなければ再度ReDimする)。
  ix = 0
  ds(ix) = Dir(path & "*.*", vbDirectory)
  Do While ds(ix) <> ""
    'カレントフォルダと親フォルダは無視。
    'また、本当にディレクトリかどうか、GetAttrで確認する。
    If ds(ix) <> "." And ds(ix) <> ".." And (GetAttr(path & ds(ix)) And vbDirectory) = vbDirectory Then
      ix = ix + 1
      If ix Mod CLUSTER_SIZE = 0 Then
        ReDim Preserve ds(0 To UBound(ds) + CLUSTER_SIZE)
      End If
    End If
    ds(ix) = Dir
  Loop

  'サブフォルダに対して再帰。
  num = ix
  For ix = 0 To num - 1
    If Not uTraverseFolders(path & ds(ix) & "\", filter, subFolder) Then   '継続しない?
      uTraverseFolders = False
      Exit Function
    End If
  Next ix

End Function

dTraverseFoldersOnFolder()とdTraverseFoldersOnFile()はデリゲート関数です。後述します。

デリゲート

ここまでに挙げた検索やフォルダ走査のコードは、すべて汎用的な関数です。検索してマッチしたときに何をしたいか(例えば、置換したいのか、マッチ回数をカウントしたいのか)とか、フォルダを走査して見つけたファイルに対して何をしたいか(ファイル内を検索したいとか、ファイルをコピーしたいとか)といった、ニーズには依存しません。今回、そういったアプリ固有の処理は、デリゲート関数に任せることにしました。

検索とフォルダ走査におけるデリゲート関数は以下の通りです。

関数コールバックタイミング引数
dFindKeywordOnMatchRangeセルがキーワードにマッチしたとき。シート、キーワード、マッチしたセル。
dFindKeywordOnMatchShape図形内のテキストがキーワードにマッチしたとき。シート、キーワード、図形、図形内のテキスト。
dTraverseFoldersOnFolderフォルダの走査を始めるとき。フォルダパス。
dTraverseFoldersOnFileフォルダ内にファイルを見つけたとき。フォルダパス、ファイル名

関数名は固定です。VBAでは、関数がファーストクラスなデータではないし、関数ポインタも無いので、こんな設計になってしまいました。

デリゲート関数のプロトタイプ
Public Function dFindKeywordOnMatchRange(sh As Worksheet, kw As String, match As Range) As Boolean
End Function

Public Function dFindKeywordOnMatchShape(sh As Worksheet, kw As String, match As shape, text As String) As Boolean
End Function

Public Function dTraverseFoldersOnFolder(path As String) As Boolean
End Function

Public Function dTraverseFoldersOnFile(path As String, fname As String) As Boolean
End Function

各デリゲートは、処理を継続するかどうかをBooleanで返す仕様です。

では、全ファイル検索のためのデリゲートを実装してみましょう。今回は、custom.basに実装しました。

デリゲート関数(custom.bas)
Const AUTO_CONTINUE As Boolean = True

'uFindKeyword()のデリゲート。
'セルにマッチしたときにコールバックされる。
'Trueを返せば、検索継続。
Public Function dFindKeywordOnMatchRange(sh As Worksheet, kw As String, match As Range) As Boolean
  
  TextBoard.addText vbTab & vbTab & "[" & sh.Name & "]" & match.MergeArea.Address(False, False, xlA1)
  
  If AUTO_CONTINUE Then
    dFindKeywordOnMatchRange = True
  Else
    match.Select
    dFindKeywordOnMatchRange = (MsgBox("Found: " & match.text & vbCrLf & "in " & match.MergeArea.Address(False, False, xlA1), vbOKCancel) = vbOK)
  End If
End Function

'uFindKeyword()のデリゲート。
'図形にマッチしたときにコールバックされる。
'Trueを返せば、検索継続。
Public Function dFindKeywordOnMatchShape(sh As Worksheet, kw As String, match As shape, text As String) As Boolean
  If AUTO_CONTINUE Then
    dFindKeywordOnMatchShape = True
  Else
    match.TopLeftCell.Select
    dFindKeywordOnMatchShape = (MsgBox("Found: " & text & vbCrLf & "in " & match.Name & "(near " & match.TopLeftCell.Address(False, False, xlA1) & ")", vbOKCancel) = vbOK)
  End If
End Function

'uTraverseFolders()のデリゲート。
'走査対象フォルダごとに1度ずつコールバックされる。
Public Function dTraverseFoldersOnFolder(path As String) As Boolean
  TextBoard.addText path
  
  If AUTO_CONTINUE Then
    dTraverseFoldersOnFolder = True
  Else
    dTraverseFoldersOnFolder = (MsgBox("Looking at: " & path, vbOKCancel) = vbOK)
  End If
End Function

'uTraverseFolders()のデリゲート。
'ファイルごとに1度ずつコールバックされる。
Public Function dTraverseFoldersOnFile(path As String, fname As String) As Boolean
  TextBoard.addText vbTab & fname
  
  Dim opened As Boolean
  opened = uWorkbookOpened(fname)
  Dim wb As Workbook
  Set wb = uOpenWorkbook(path & fname)
  uFindKeywordInBook wb, "1", False
  If Not opened Then
    wb.Close False
  End If
  
  If AUTO_CONTINUE Then
    dTraverseFoldersOnFile = True
  Else
    dTraverseFoldersOnFile = (MsgBox("Found: " & fname & vbCrLf & "on " & path, vbOKCancel) = vbOK)
  End If
End Function

フォルダ走査でファイルを見つけたら、そのファイルに対して全シート検索を行っています。キーワードの与え方については、もっと工夫した方が良さそうですね。また、走査するファイルは"*.xls*"である、という前提のコードになっています。

フォルダ名、ファイル名、検索結果(マッチ箇所のシート名とセルアドレス)は、TextBoardに蓄積します。TextBoardについては後述します。

各デリゲートは、デフォルトでTrue(処理継続)を返しますが、AUTO_CONTINUEをFalseに変えれば、メッセージボックスでユーザに問い合わせるようになります。

使用例

こんな感じで呼びます。

Load TextBoard
uTraverseFolders "d:\etude\vba", "*.xls*", True
TextBoard.Show

結果は、こんな感じ。

検索結果

TextBoard

TextBoardは、全面にエディットボックスを貼ったフォームです。TextBoard.addText()で文字列を追加できるようになっています。

詳細は、添付ファイルのTextBoard.frmを参照して下さい。インポートするなら、TextBoard.frxも必要かな。

その他の汎用関数(utils.bas)

パスの補正
'必要に応じて、パスの最後に、"\"を付ける。
Public Function uPathWithSeparator(path As String) As String
  If right(path, 1) = "\" Then
    uPathWithSeparator = path
  Else
    uPathWithSeparator = path & "\"
  End If
End Function
ワークブックのオープン状態調査
'ワークブックがオープン済みかどうか。
'fnameには、パス無しのファイル名を指定。
Public Function uWorkbookOpened(fname As String) As Boolean
  For Each wb In Workbooks
    If wb.Name = fname Then
      uWorkbookOpened = True
      Exit Function
    End If
  Next

  uWorkbookOpened = False
End Function
ワークブックを開く
'ワークブックを開く。
Public Function uOpenWorkbook(path As String) As Workbook
  Dim fname As String
  fname = Dir(path)
  If uWorkbookOpened(fname) Then
    Set uOpenWorkbook = Workbooks(fname)
    uOpenWorkbook.Activate
  Else
    Set uOpenWorkbook = Workbooks.Open(path)
  End If
End Function
Last modified:2013/08/13 19:38:09
Keyword(s):
References:[Windowsリテラシ]
This page is frozen.