こんにちは！ 健史です。
Excelの文字列検索で、
と思われたことありませんか。
赤枠で囲った部分です。
例えば検索する文字が「ある影響範囲を調べるもの」で、リストアップされた１つひとつのドキュメントなどを確認する場合、チェック一覧表として使用したい場合です。
上記部分をコピーしようとしましたが、できませんでした。
所定のフォルダに格納された複数のExcelファイルすべてのシートから文字列を抽出し、リストアップするプログラムを作成しました。
・検索する文字を一度に複数を設定
・検索するフォルダはフォルダ内のファイルのみ、サブフォルダを含む全てを設定
できます。
設定シート&リストアップシート&プログラム
1.シート１に設定シート、シート２とシート３に空白のシートを作成
1).シート１に以下を貼り付けます。
ドラッグ＆コピー後にExcelに貼り付けるとき、[形式を選択して貼り付ける]-[テキスト]で貼り付けます。(セル[A1]で[右クリック]、[形式を選択して貼り付ける]-[テキスト])を指定します。
項目名 設定値 備 考 シート３の見出し 入力フォルダ C:\Users\yohze\Documents\Fドライブ\70.EXCEL-VBA 必須 検索文字 フォルダ名 ファイル名 シート№ シート名 セル セルの内容 検索レベル M 入力フォルダのみ：S、下位サブフォルダまで：M 検索タイプ 省略：部分一致、空白以外：全体一致 検索文字 sample2 必須 sample3 以降は省略可
イエローでマーキングしたセル[B2]以降を設定します。以下、補足説明です。
・検索レベル
指定したフォルダ内直下のファイルのみか[S]、フォルダ内のサブフォルダ全て[M]を対象にするかを指定します。(S:シングルレベル、M:マルチレベル)
検索ファイルは、拡張子3文字に[.xls]を持つ[.xls][.xlsx][.xlsm]などのファイルが対象になります。
１つのファイルを対象にしたい場合は、検索フォルダに対象ファイルだけを置いて、[S]シングルレベルを指定します。
・検索タイプ
全体一致を指定する場合には"0"でも"A"でも空白以外になるよう何らかの文字を入力します。
・検索文字
1つは必須です。2つ目以降は任意で入力できる分だけ指定できますが、検査結果の上限を想定し指定頂ければと思います。
2).シート２とシート３を追加します。中身は空です。
※追加を忘れたときのために、シート２とシート３が存在しない場合は、自動で追加するよう対応しました。
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 sh1, sh2, sh3, ws1 As Worksheet
'範囲を変数として定義
Dim rng_1, rng_tmp As Range
'－－－－－ レベル：０ －－－－－ メイン処理
Sub MAIN00()
'画面遷移を表示させない設定
Application.ScreenUpdating = False
'変数:excel1に起動した(この)ファイルを設定
Set excel0 = ActiveWorkbook
Select Case excel0.Sheets.Count 'シート２，シート３を追加し忘れた時の対応
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
Set sh1 = excel0.Sheets(1)
Set sh2 = excel0.Sheets(2)
Set sh3 = excel0.Sheets(3)
'起動した(この)ファイルのシートからワーク領域へ取り込み
strPath = sh1.Cells(2, 2)
strFindlvl = sh1.Cells(3, 2)
strFind = sh1.Cells(4, 2)
'各シートを初期クリア、見出しセット
sh2.Cells.Clear
sh3.Cells.Clear
For iy1 = 1 To 7
sh3.Cells(1, iy1) = sh1.Cells(2, iy1 + 4)
Next
'ワーク領域へ取り込んだ項目のチェック
If Dir(strPath, vbDirectory) = "" Then
MsgBox "対象フォルダがありません！"
Exit Sub
End If
'
Select Case strFindlvl
Case "S", "M"
Case Else
MsgBox "検索レベルが間違っています！"
Exit Sub
End Select
'
If sh1.Cells(cnsFROM, 2) = "" Then
MsgBox "検索文字が１つも指定されていません！"
Exit Sub
End If
'検索文字が１つの場合は、ix0_1_maxはcnsFROMをセット
If sh1.Cells(cnsFROM + 1, 2) = "" Then
ix0_1_max = cnsFROM 'ExcelのＭＡＸ行 1,048,576を取得しないように
Else
ix0_1_max = sh1.Cells(cnsFROM, 2).End(xlDown).Row
End If
'検索フォルダからファイルの所在情報をシート２に取得
ix0_2 = 0
Call SUB99_DIRLIST(strPath)
ix0_2_max = ix0_2
'検索結果をシート３へセットするため添字に１を設定
ix0_3 = 1
'シート２から取得した検索対象ファイルがなくなるまで繰り返す
'---Application.StatusBar = "0/" & ix0_2_max
For ix0_2 = 1 To ix0_2_max
'ステータスバーに件数を表示
Application.StatusBar = ix0_2 & "/" & ix0_2_max
'-------If ix0_2 Mod 10 = 0 Then Application.StatusBar = ix0_2 & "/" & ix0_2_max
'検索対象ファイルのオープンと同時に変数:excel1へ設定、読み取り専用を推奨するメッセージを非表示、リンク更新しない
Set excel1 = Workbooks.Open(sh2.Cells(ix0_2, 1), IgnoreReadOnlyRecommended:=True, UpdateLinks:=0)
'すべてのシート(Sheets.Count)を処理する
For cntSht = 1 To excel1.Sheets.Count
'変数:ws1へワークシートをセット
Set ws1 = excel1.Sheets(cntSht)
'変数:wsのワークシートから最終行・列を取得する
ix1_max = ws1.UsedRange.Rows(ws1.UsedRange.Rows.Count).Row
iy1_max = ws1.UsedRange.Columns(ws1.UsedRange.Columns.Count).Column
'検索する範囲を変数:rng_1へセットし最初に見つかる文字を検索する
Set rng_1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(ix1_max, iy1_max))
For ix0_1 = cnsFROM To ix0_1_max
strChr = sh1.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
'検索結果をシート３へセットし、次の文字を検索する
Do
ix1 = rng_tmp.Row
iy1 = rng_tmp.Column
ix0_3 = ix0_3 + 1
sh3.Cells(ix0_3, 1) = strChr
sh3.Cells(ix0_3, 2) = sh2.Cells(ix0_2, 2)
sh3.Cells(ix0_3, 3) = sh2.Cells(ix0_2, 3)
sh3.Cells(ix0_3, 4) = cntSht
sh3.Cells(ix0_3, 5) = ws1.Name
sh3.Cells(ix0_3, 6) = Replace(rng_tmp.Address, "$", "")
sh3.Cells(ix0_3, 7) = ws1.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
'---Application.StatusBar = ix0_2 - 1 & "/" & ix0_2_max
'最後にファイル名、シート№、セルでソート
sh3.UsedRange.Sort _
Key1:=sh3.Range("A1"), Order1:=xlAscending, _
Key1:=sh3.Range("C1"), Order1:=xlAscending, _
Key1:=sh3.Range("D1"), Order1:=xlAscending, _
Key1:=sh3.Range("F1"), Order1:=xlAscending, _
Header:=xlYes
'上書き保存
excel0.Save
sh3.Activate '検索結果であるリストアップシートに位置付ける
'
MsgBox "処理終了！"
End Sub
'－－－－－ レベル：１ －－－－－
'ディレクトリリスト：シート２に取得
Sub SUB99_DIRLIST(ByVal Path As String)
Dim objFile As Object
strFilename = Dir(Path & cnsDIR)
Do While strFilename <> ""
ix0_2 = ix0_2 + 1
sh2.Cells(ix0_2, 1) = Path & "\" & strFilename
sh2.Cells(ix0_2, 2) = Path
sh2.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)]をクリックします。
シート３に検索した内容がリストアップされています。
処理内容説明
上記プログラムは以下の記事のプログラムを流用しており、詳細を記載しています。
その他を補足します。
◆読み込むファイル種類
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.ボタンを設置したいシートから、[開発(L)]-[挿入(I)]-[ボタン(フォームコントロール)(B)]からマウスを使ってボタンを配置します。
[開発]タブを表示させる方法：Excel上で、ファイル(F)-オプション(T)から[リボンのユーザ設定]から、画面の右[リボンのユーザ設定(B)]で「開発」にチェックを入れる
2.上記[1.]の後に開く画面において、下段に入っているマクロ名をクリックして上段の[マクロ名(M):]にセットし、[OK]ボタンをクリックします。
※上記画像ではマクロが[test1]になっていますが、当プログラムでは[MAIN00]になっていますので[MAIN00]を選択します。
ボタンからの実行がうまくいかない場合は、以下の記事を参照頂ければと思います。
追加機能の説明
当記事は公開時から何度かアップデートしましたが、2025年7月から追加した機能を明示します。(機能が変わらない変更は除く)
検索の進捗表示
Application.StatusBar = ix0_2 & "/" & ix0_2_max
検索実行中、処理の進行状況を確認したいことがあります。特に検索対象が多いときです。
当処理の構造です。
1.対象ディレクトリから検索対象ファイルをシート２にリストアップ
2.シート２から一つひとつファイルをオープン・検索・クローズ
[2.]の最初に処理対象の件数表示を挿入します。具体的には、ループ内の最初です。
また、１件ずつの表示ではなく10件単位などで表示したい場合は以下です。
If ix0_2 Mod 10 = 0 Then Application.StatusBar = ix0_2 & "/" & ix0_2_max
※100件単位にする場合は、10を100に変更します。
この場合、ループの前後に以下を挿入しても良いでしょう。
・ループの前
Application.StatusBar = "0/" & ix0_2_max
・ループの後
Application.StatusBar = ix0_2 - 1 & "/" & ix0_2_max
または、
Application.StatusBar = ix0_2_max & "/" & ix0_2_max
検索ファイルオープン時のリンク更新のスキップ
Set excel1 = Workbooks.Open(excel0.Sheets(2).Cells(ix0_2, 1), IgnoreReadOnlyRecommended:=True, UpdateLinks:=0)
の「UpdateLinks:=0」
検索対象ファイルにリンクのあるセルがあると、以下の画面が表示され、検索処理が中断します。
[UpdateLinks:=0]は、「更新しない(N)」の選択です。
最後に
検索結果は別ファイルとして新しいファイルに出力することもできます。
検索対象が多い場合に実行中は、Ｅｘｃｅｌを使用できません。
検索する業務が一時的に集中する場合や頻繁に使用する場合は、もし組織内に使っていないパソコンがあれば借りることをお薦めします。
事情を話して、一時的にでも借りられるパソコンがあるかを確認し、あれば「借りられますか」と、ダメ元でまず聞いてみることです。聞かないとはじまりません。
もしあれば使っていないのですから勿体ないです。使う場合に返却すればよいのですから。
そして、借りたパソコンに検索対象プログラムとファイル群をコピーし、検索します。
そうすることで、業務をコンカレントに行い、生産性を向上できます。
いずれにしても、早く終わりにして早く帰れますように。
コメント