EXCEL VBA

Excel-VBA 文字列の検索、複数ファイル複数シートの検索結果を出力

EXCEL VBA

こんにちは! 健史(たけふみ)です。

Excelの文字列検索で、「検索した結果をデータとして出力できないかな?」と思われたことありませんか。

赤枠で囲った部分です。

例えば検索した文字が「ある影響範囲を調べたもの」で、リストアップされた1つひとつのドキュメントなどを確認する場合、チェック一覧表として使用したい場合です。

上記部分をコピーしようとしましたが、できませんでした。

所定のフォルダに格納された複数のExcelファイルすべてのシートから文字列を抽出し、リストアップするマクロを作成しました。

検索対象に特定ファイル1つを指定することもできます。

スポンサーリンク

設定シート&リストアップシート&プログラム

1.シート1に設定シート、シート2に空白のシートを作成

1).シート1に以下を貼り付けます。
ドラッグ&コピー後にExcelに貼り付けるとき、[形式を選択して貼り付ける]-[テキスト]で貼り付けます。(セル[A1]で[右クリック]、[形式を選択して貼り付ける]-[テキスト])を指定します。

項目名	設定値	備 考
検索文字	sample1	
検索タイプ		空白:部分一致、空白以外:全体一致
入力フォルダ	C:\TEMP01\検索対象フォルダ	
入力ファイル		

・検索タイプは、全体一致を指定する場合には"0"でも"A"でも空白以外になるよう何らかの文字を入力します。

・検索対象に特定ファイル1つを指定する場合は、入力ファイルに例えば[FILE01.xlsx]と指定します。([]内のファイル名)

・入力ファイルを指定しなければ、入力フォルダ内の拡張子3文字に[.xls]を持つ[.xls][.xlsx][.xlsm]などのファイルが対象になります。

2).シート2を追加します。中身は空です。

2.上記ExcelファイルのVBAエディタでプログラムを貼り付け、実行

1).上記ExcelファイルからAltを押した状態でF8を押下後、マクロ名を入力して[作成(C)]をクリックします。

マクロ名はtestでもchar_findなど適当に。ただしselectなどマクロ名に指定できないものもあります。

2).以下のプログラムをコピーし、貼り付けます。

'対象ファルダから読み込むファイルを指定。Excelのみにする場合は"\*.xlsx"や"\*.xls"
    Const cnsDIR = "\*.xls*"
'エクセルシートを複数同時に使うので、変数として定義
    Dim excel0 As Workbook
    Dim excel1 As Workbook
'変数定義
    Dim ix1, ix2, iy2, ix2_max, iy2_max, ix2_sav, iy2_sav As Long
    Dim strChr, stFind, strPath, strFile, strFilename As String
    Dim cntSht As Long
'ワークシート、範囲を変数として定義
    Dim ws As Worksheet
    Dim rng_1, rng_tmp As Range
'変数:excel1に起動した(この)ファイルを設定
    Set excel0 = ActiveWorkbook
'起動した(この)ファイルのシートからワーク領域へ取り込み
    strChr = excel0.Worksheets(1).Cells(2, 2)
    strFind = excel0.Worksheets(1).Cells(3, 2)
    strPath = excel0.Worksheets(1).Cells(4, 2)
    strFile = excel0.Worksheets(1).Cells(5, 2)
'起動した (この) 'ワーク領域へ取り込んだ項目のチェック
    excel0.Sheets(2).Cells.Clear
    excel0.Sheets(2).Cells(1, 1) = "フォルダ名"
    excel0.Sheets(2).Cells(1, 2) = "ファイル名"
    excel0.Sheets(2).Cells(1, 3) = "シート№"
    excel0.Sheets(2).Cells(1, 4) = "シート名"
    excel0.Sheets(2).Cells(1, 5) = "セル"
    excel0.Sheets(2).Cells(1, 6) = "セルの内容"
'
    If Dir(strPath, vbDirectory) = "" Then
        MsgBox "対象フォルダがありません!"
        Exit Sub
    End If
'
    If strFile <> "" Then
       If Dir(strPath & "\" & strFile, vbDirectory) = "" Then
           MsgBox "対象ファイルがありません!"
           Exit Sub
        End If
    End If
'起動した(この)ファイルのシート2へセットするための添字に1を設定
    ix1 = 1
'対象フォルダから最初のファイル名を取得
    If strFile = "" Then
        strFilename = Dir(strPath & cnsDIR, vbNormal)
'ファイル名を入力したときは、そのファイルだけを対象にする
    Else
        strFilename = strFile
    End If
'対象フォルダのファイル名を取得できなくなるまで繰り返す
    Do While strFilename <> ""
'取得したファイルをオープンすると同時し、変数:excel2へ設定
        Set excel1 = Workbooks.Open(strPath & "\" & strFilename)
'すべてのシート(Worksheets.Count)を処理する
        For cntSht = 1 To excel1.Worksheets.Count
'変数:wsへワークシートをセット
            Set ws = excel1.Worksheets(cntSht)
'変数:wsのワークシートから最終行・列を取得する
            ix2_max = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
            iy2_max = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
'検索する範囲を変数:rng_1へセットし最初に見つかる文字を検索する
            Set rng_1 = ws.Range(ws.Cells(1, 1), ws.Cells(ix2_max, iy2_max))
            If strFind = "" Then
              Set rng_tmp = rng_1.Find(strChr, LookIn:=xlValues, lookat:=xlPart)
            Else
                Set rng_tmp = rng_1.Find(strChr, LookIn:=xlValues, lookat:=xlWhole)
            End If
'検索する文字がなければスキップしL100へジャンプ
            If rng_tmp Is Nothing Then
                GoTo L100
            End If
'最初に見つかった文字の行・列を退避しておく
            ix2_sav = rng_tmp.Row
            iy2_sav = rng_tmp.Column
'起動した(この)ファイルのシート2へ項目をセットし、次の文字を検索する
            Do
                ix2 = rng_tmp.Row
                iy2 = rng_tmp.Column
                If (strFind = "") Or _
                    (strFind <> "" And strChr = ws.Cells(ix2, iy2)) Then
                    ix1 = ix1 + 1
                    excel0.Worksheets(2).Cells(ix1, 1) = strPath
                    excel0.Worksheets(2).Cells(ix1, 2) = strFilename
                    excel0.Worksheets(2).Cells(ix1, 3) = cntSht
                    excel0.Worksheets(2).Cells(ix1, 4) = ws.Name
                    excel0.Worksheets(2).Cells(ix1, 5) = Replace(rng_tmp.Address, "$", "")
                    excel0.Worksheets(2).Cells(ix1, 6) = ws.Cells(ix2, iy2)
                End If
                Set rng_tmp = rng_1.FindNext(rng_tmp)
'次に検索した文字が退避した行・列と同じになったら終了
            Loop Until rng_tmp.Row = ix2_sav And rng_tmp.Column = iy2_sav
L100:  '検索する文字がなかった場合のジャンプ先
        Next
'読み込んだファイルを閉じる
        excel1.Close
'対象フォルダから次のファイル名を取得する
        If strFile = "" Then
            strFilename = Dir()
'ファイル名を入力したときは、そのファイルだけを対象に処理を終えるためNULLをセット
        Else
            strFilename = ""
        End If
    Loop
'最後にファイル名、シート№、セルでソート
    excel0.Sheets(2).UsedRange.Sort _
            Key1:=excel0.Sheets(2).Range("B1"), Order1:=xlAscending, _
            Key2:=excel0.Sheets(2).Range("C1"), Order2:=xlAscending, _
            Key3:=excel0.Sheets(2).Range("E1"), Order3:=xlAscending, _
            Header:=xlYes
'
    excel0.Save

3).ファイルの種類を[Excel マクロ有効ブック(*.xlsm)]で、一旦保存しておきます。
保存先には、検索対象のファイルを格納するフォルダ以外を指定します。

4).再びAltを押した状態でF8を押下し、[実行(R)]をクリックします。

シート2に検索した内容がリストアップされています。

処理内容説明

上記プログラムは以下の記事のプログラムを流用しており、詳細を記載しています。

Excel-VBA 実例 Excelの文字列を一括検索・置換
こんにちは! 健史(たけふみ)です。 Excelファイルで保管されている文書の文字列を一括で修正したいということありませんか。 プログラムで指定したフォルダ内のExcelファイルの文字列を修正する処理を作成してみました。 ...

その他を補足します。

・読み込むファイル種類
Excelファイルだけを対象するため[Const cnsDIR = "\*.xls*"]に変更しています。

・With命令を使わない、見出し部分をプログラムでコーディング
同じ内容のコーディング量を減らすためのWith命令を使わなくしました。
 
またシート2の見出し部分をプログラムでコーディングしました。
 
理由を強いて述べるなら「いろいろなコーディング方法があることを紹介したいため」でしょうか。

ボタンで処理を開始したい

以下のようにボタンを付けます。

1.ボタンを設置したいシートから、[開発(L)]-[挿入(I)]-[ボタン(フォームコントロール)(B)]からマウスを使ってボタンを配置します。

[開発]タブを表示させる方法:Excel上で、ファイル(F)-オプション(T)から[リボンのユーザ設定]から、画面の右[リボンのユーザ設定(B)]で「開発」にチェックを入れる

2.上記[1.]の後に開く画面において、下段に入っているマクロ名をクリックして上段の[マクロ名(M):]にセットし、[OK]ボタンをクリックします。

ボタンからの実行がうまくいかない場合は、以下の記事を参照頂ければと思います。

マクロ''を実行できません。このブックのマクロを使用できないか、またはすべてのマクロが無効になっている可能性があります
Excelマクロを作成しボタンから実行しようとボタンを作成したけれど動かない!ネットでエラーの内容を調べてみるけど問題なし。作成方法を間違っているのかもしれません。間違いを間違いと気づかずに。一度ダメ元でやってみて頂ければと思います。

最後に

今回は、起動するExcelシートのシート2に検索した内容をリストアップしてみました。

別ファイルとして新しいファイルに出力することもできます。
ご参考:



リストアップしたシートは用途によっては不要な部分がありますから、加工してご利用頂ければと思います。

EXCEL VBA
スポンサーリンク
- 面白かったらシェアお願いします! -
健史をフォローする
自分で改善

コメント