EXCEL VBA

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

EXCEL VBA

こんにちは! 健史です。

Excelの文字列検索で、

検索した結果をデータとして出力できないかな?

と思われたことありませんか。

赤枠で囲った部分です。

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

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

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

検索する文字を一度に複数を設定
・検索するフォルダはフォルダ内のファイルのみサブフォルダを含む全てを設定
できます。

スポンサーリンク

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

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

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

項目名	設定値	備 考
入力フォルダ	C:\temp01\01.IN	必須
検索レベル	M	入力フォルダのみ:S、下位サブフォルダまで:M
検索タイプ		省略:部分一致、空白以外:全体一致
検索文字	sample2	必須
	sample3	以降は省略可

検索レベル
指定したフォルダ内直下のファイルのみか[S]、フォルダ内のサブフォルダ全て[M]を対象にするかを指定します。(S:シングルレベル、M:マルチレベル)

検索ファイルは、拡張子3文字に[.xls]を持つ[.xls][.xlsx][.xlsm]などのファイルが対象になります。

1つのファイルを対象にしたい場合は、検索フォルダに対象ファイルだけを置いて、[S]シングルレベルを指定します。

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

検索文字
1つは必須です。2つ目以降は任意で入力できる分だけ指定できますが、検査結果の上限を想定し指定頂ければと思います。

2).シート2とシート3を追加します。中身は空です。
※追加を忘れたときのために、シート2とシート3が存在しない場合は、自動で追加するよう対応しました。

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

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

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

以下の内容が記述された画面に遷移しますが、すべてを削除します。


※今回の手順に従い登録すると、マクロ名はプログラム内に記述されているマクロ名[MAIN00]になります。

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

'----- 変数定義 -----
'定数 cnsFROMは設定シートの検索文字の開始行、設定項目行を追加したら変更
    Const cnsDIR = "\*.xls*"
    Const cnsFROM = 5
'可変変数(一般というか通常の変数)
    Dim ix0_1, ix0_1_max, ix0_2, ix0_2_max, ix0_3, ix1, iy1, ix1_max, iy1_max, ix1_sav, iy1_sav As Long
    Dim strChr, stFind, strPath, strFindlvl, strFilename As String
    Dim cntSht As Long
'エクセルシートを複数同時に使うので、変数として定義
    Dim excel0, excel1 As Workbook
'ワークシート、範囲を変数として定義
    Dim ws As Worksheet
    Dim rng_1, rng_tmp As Range
'----- レベル:0 ----- メイン処理
Sub MAIN00()
'画面遷移を表示させない設定
    Application.ScreenUpdating = False
'変数:excel1に起動した(この)ファイルを設定
    Set excel0 = ActiveWorkbook
'起動した(この)ファイルのシートからワーク領域へ取り込み
    strPath = excel0.Sheets(1).Cells(2, 2)
    strFindlvl = excel0.Sheets(1).Cells(3, 2)
    strFind = excel0.Sheets(1).Cells(4, 2)
'各シートを初期クリア、見出しセット
    Select Case excel0.Sheets.Count   'シート2,シート3を追加し忘れた時の対応
    Case 1
        excel0.Sheets.Add(After:=excel0.Sheets(excel0.Sheets.Count)).Name = "ワーク"
        excel0.Sheets.Add(After:=excel0.Sheets(excel0.Sheets.Count)).Name = "リストアップ"
    Case 2
        excel0.Sheets.Add(After:=excel0.Sheets(excel0.Sheets.Count)).Name = "リストアップ"
    End Select
    excel0.Sheets(2).Cells.Clear
    excel0.Sheets(3).Cells.Clear
    excel0.Sheets(3).Cells(1, 1) = "検索文字"
    excel0.Sheets(3).Cells(1, 2) = "フォルダ名"
    excel0.Sheets(3).Cells(1, 3) = "ファイル名"
    excel0.Sheets(3).Cells(1, 4) = "シート№"
    excel0.Sheets(3).Cells(1, 5) = "シート名"
    excel0.Sheets(3).Cells(1, 6) = "セル"
    excel0.Sheets(3).Cells(1, 7) = "セルの内容"
'ワーク領域へ取り込んだ項目のチェック
    If Dir(strPath, vbDirectory) = "" Then
        MsgBox "対象フォルダがありません!"
        Exit Sub
    End If
'
    Select Case strFindlvl
    Case "S", "M"
    Case Else
         MsgBox "検索レベルが間違っています!"
         Exit Sub
    End Select
'
    If excel0.Sheets(1).Cells(cnsFROM, 2) = "" Then
         MsgBox "検索文字が1つも指定されていません!"
         Exit Sub
    End If
'検索文字が1つの場合は、ix0_1_maxはcnsFROMをセット
    If excel0.Sheets(1).Cells(cnsFROM + 1, 2) = "" Then
        ix0_1_max = cnsFROM     'ExcelのMAX行 1,048,576を取得しないように
    Else
        ix0_1_max = excel0.Sheets(1).Cells(cnsFROM, 2).End(xlDown).Row
    End If
'検索フォルダからファイルの所在情報をシート2に取得
    ix0_2 = 0
    Call SUB99_DIRLIST(strPath)
    ix0_2_max = ix0_2
'検索結果をシート3へセットするため添字に1を設定
    ix0_3 = 1
'シート2から取得した検索対象ファイルがなくなるまで繰り返す
    For ix0_2 = 1 To ix0_2_max
'検索対象ファイルのオープンと同時に変数:excel1へ設定、読み取り専用を推奨するメッセージを非表示
        Set excel1 = Workbooks.Open(excel0.Sheets(2).Cells(ix0_2, 1), IgnoreReadOnlyRecommended:=True)
'すべてのシート(Sheets.Count)を処理する
        For cntSht = 1 To excel1.Sheets.Count
'変数:wsへワークシートをセット
            Set ws = excel1.Sheets(cntSht)
'変数:wsのワークシートから最終行・列を取得する
            ix1_max = ws.UsedRange.Rows(ws.UsedRange.Rows.Count).Row
            iy1_max = ws.UsedRange.Columns(ws.UsedRange.Columns.Count).Column
'検索する範囲を変数:rng_1へセットし最初に見つかる文字を検索する
            Set rng_1 = ws.Range(ws.Cells(1, 1), ws.Cells(ix1_max, iy1_max))
            For ix0_1 = cnsFROM To ix0_1_max
                strChr = excel0.Sheets(1).Cells(ix0_1, 2)
                If strFind = "" Then
                    Set rng_tmp = rng_1.Find(strChr, LookIn:=xlValues, _
                    lookat:=xlPart, SearchOrder:=xlByColumns)
                Else
                    Set rng_tmp = rng_1.Find(strChr, LookIn:=xlValues, _
                    lookat:=xlWhole, SearchOrder:=xlByColumns)
                End If
'検索する文字がなければスキップしL100へジャンプ
                If rng_tmp Is Nothing Then
                    GoTo L100
                End If
'最初に見つかった文字の行・列を退避しておく
                ix1_sav = rng_tmp.Row
                iy1_sav = rng_tmp.Column
'検索結果をシート3へセットし、次の文字を検索する
                Do
                    ix1 = rng_tmp.Row
                    iy1 = rng_tmp.Column
                    ix0_3 = ix0_3 + 1
                    excel0.Sheets(3).Cells(ix0_3, 1) = strChr
                    excel0.Sheets(3).Cells(ix0_3, 2) = excel0.Sheets(2).Cells(ix0_2, 2)
                    excel0.Sheets(3).Cells(ix0_3, 3) = excel0.Sheets(2).Cells(ix0_2, 3)
                    excel0.Sheets(3).Cells(ix0_3, 4) = cntSht
                    excel0.Sheets(3).Cells(ix0_3, 5) = ws.Name
                    excel0.Sheets(3).Cells(ix0_3, 6) = Replace(rng_tmp.Address, "$", "")
                    excel0.Sheets(3).Cells(ix0_3, 7) = ws.Cells(ix1, iy1)
'次を検索し、退避した行・列と同じになったら終了
                    Set rng_tmp = rng_1.FindNext(rng_tmp)
                Loop Until rng_tmp.Row = ix1_sav And rng_tmp.Column = iy1_sav
L100:   '検索する文字がなかった場合のジャンプ先
            Next
        Next
        excel1.Close SaveChanges:=False  '検索対象ファイルを保存しないで閉じる
    Next
'最後にファイル名、シート№、セルでソート
    excel0.Sheets(3).UsedRange.Sort _
            Key1:=excel0.Sheets(3).Range("A1"), Order1:=xlAscending, _
            Key1:=excel0.Sheets(3).Range("C1"), Order1:=xlAscending, _
            Key1:=excel0.Sheets(3).Range("D1"), Order1:=xlAscending, _
            Key1:=excel0.Sheets(3).Range("F1"), Order1:=xlAscending, _
            Header:=xlYes
'上書き保存
    excel0.Save
    excel0.Sheets(3).Activate   '検索結果であるリストアップシートに位置付ける
    MsgBox "処理終了!"
End Sub
'----- レベル:1 -----
'ディレクトリリスト:シート2に取得
Sub SUB99_DIRLIST(ByVal Path As String)
    Dim objFile As Object
    strFilename = Dir(Path & cnsDIR)
    Do While strFilename <> ""
        ix0_2 = ix0_2 + 1
        excel0.Sheets(2).Cells(ix0_2, 1) = Path & "\" & strFilename
        excel0.Sheets(2).Cells(ix0_2, 2) = Path
        excel0.Sheets(2).Cells(ix0_2, 3) = strFilename
        strFilename = Dir()
    Loop
'検索レベルがシングルのときは、取得終了
    Select Case strFindlvl
    Case "S"
        Exit Sub
    End Select
'検索レベルがマルチのとき、サブフォルダまで検索
    For Each objFile In CreateObject("Scripting.FileSystemObject").GetFolder(Path).SubFolders
        Call SUB99_DIRLIST(objFile.Path)
    Next objFile
End Sub

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

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

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

処理内容説明

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

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

その他を補足します。

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

◆CreateObject("Scripting.FileSystemObjectの使用について
サブフォルダまでを対象にする場合は、[CreateObject("Scripting.FileSystemObject")]を使用します。

With句で記述する場合は以下です。

以下は、上記[CreateObject("Scripting.FileSystemObject")]と同じ
    With CreateObject("Scripting.FileSystemObject")
        For Each objFile In .GetFolder(Path).SubFolders
            Call Dirlist(objFile.Path)
        Next objFile
    End With

◆検索順に注意:列方向、行方向
検索文字をセットして検索しますが、そのとき検索順[列方向、行方向]を指定します。

・列方向 SearchOrder:=xlByColumns
・行方向 SearchOrder:=xlByRows

指定しなければ「行方向」になります。

試した限りにおいて、

検索対象文字が1シート内に1つのみ存在し、かつ、該当文字が行結合したセル内にある

場合にエラーになります。

回避策として、検索順を列方向にする必要があります。

ちなみに、検索順が列方向であっても「検索対象文字が1シート内に1つのみ存在し、かつ、該当文字が列結合したセル内にある」場合はエラーになりませんでした。

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

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

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

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

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

※上記画像ではマクロが[test1]になっていますが、当プログラムでは[MAIN00]になっていますので[MAIN00]を選択します。


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

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

最後に

プログラムは、「ディレクトリリストをシート2に取得する[Sub Dirlist(ByVal Path As String)]、その中でも[For Each objFile~]」部分を除き、基本的なコマンドのみを使うようにして、読みやすく理解しやすいようにしています。
(著者自身、上記「除く部分」は今でも「このように書けば良い!」と思っており、「覚えられない=そのように書けばよし」としています)

尚、検索結果は別ファイルとして新しいファイルに出力することもできます。

Excel-VBA 複数のファイルをひとつのファイルの複数シートに集約する
こんにちは! 健史です。 ・複数のファイルを1つのファイルにシートを分けて集約する ・集約するシートにはひな形があり、ひな形のレイアウトにフォーマットを変換する プログラムを作成しました。 上記の説明では分かりにくいと思...



数多くのファイルから特定文字列を探して転記・記録する作業は時間が掛かりますし面倒です。

プログラムであれば、検索している間にExcel以外の他の作業ができます。

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

いずれにしても、早く終わりにして早く帰れますように。

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

コメント