こんにちは！ 健史です。
Excelの文字列検索で、
と思われたことありませんか。
赤枠で囲った部分です。
例えば検索する文字が「ある影響範囲を調べるもの」で、リストアップされた１つひとつのドキュメントなどを確認する場合、チェック一覧表として使用したい場合です。
上記部分をコピーしようとしましたが、できませんでした。
所定のフォルダに格納された複数のExcelファイルすべてのシートから文字列を抽出し、リストアップするプログラムを作成しました。
・検索する文字を一度に複数を設定
・検索するフォルダはフォルダ内のファイルのみ、サブフォルダを含む全てを設定
できます。
設定シート&リストアップシート&プログラム
1.シート１に設定シート、シート２とシート３に空白のシートを作成
1).シート１に以下を貼り付けます。
ドラッグ＆コピー後にExcelに貼り付けるとき、[形式を選択して貼り付ける]-[テキスト]で貼り付けます。(セル[A1]で[右クリック]、[形式を選択して貼り付ける]-[テキスト])を指定します。
項目名 設定値 備 考 入力フォルダ C:\temp01\01.IN 必須 検索レベル M 入力フォルダのみ：S、下位サブフォルダまで：M 検索タイプ 省略：部分一致、空白以外：全体一致 検索文字 sample2 必須 sample3 以降は省略可
・検索レベル
指定したフォルダ内直下のファイルのみか[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 ws As Worksheet
Dim rng_1, rng_tmp As Range
'－－－－－ レベル：０ －－－－－ メイン処理
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 'シート２，シート３を追加し忘れた時の対応
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 "検索文字が１つも指定されていません！"
Exit Sub
End If
'検索文字が１つの場合は、ix0_1_maxはcnsFROMをセット
If excel0.Sheets(1).Cells(cnsFROM + 1, 2) = "" Then
ix0_1_max = cnsFROM 'ExcelのＭＡＸ行 1,048,576を取得しないように
Else
ix0_1_max = excel0.Sheets(1).Cells(cnsFROM, 2).End(xlDown).Row
End If
'検索フォルダからファイルの所在情報をシート２に取得
ix0_2 = 0
Call SUB99_DIRLIST(strPath)
ix0_2_max = ix0_2
'検索結果をシート３へセットするため添字に１を設定
ix0_3 = 1
'シート２から取得した検索対象ファイルがなくなるまで繰り返す
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
'検索結果をシート３へセットし、次の文字を検索する
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
'－－－－－ レベル：１ －－－－－
'ディレクトリリスト：シート２に取得
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)]をクリックします。
シート３に検索した内容がリストアップされています。
処理内容説明
上記プログラムは以下の記事のプログラムを流用しており、詳細を記載しています。
その他を補足します。
◆読み込むファイル種類
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]を選択します。
ボタンからの実行がうまくいかない場合は、以下の記事を参照頂ければと思います。
最後に
プログラムは、「ディレクトリリストをシート２に取得する[Sub Dirlist(ByVal Path As String)]、その中でも[For Each objFile～]」部分を除き、基本的なコマンドのみを使うようにして、読みやすく理解しやすいようにしています。
(著者自身、上記「除く部分」は今でも「このように書けば良い！」と思っており、「覚えられない＝そのように書けばよし」としています)
尚、検索結果は別ファイルとして新しいファイルに出力することもできます。
数多くのファイルから特定文字列を探して転記・記録する作業は時間が掛かりますし面倒です。
プログラムであれば、検索している間にExcel以外の他の作業ができます。
リストアップしたシートは用途によっては不要な部分がありますから、加工してご利用頂ければと思います。
いずれにしても、早く終わりにして早く帰れますように。
コメント