趣味プログラミングblog

---

過去に似たようなものを作っていたんだけど、当時は未熟で
専用ファイルにソースを書いていたので、
そのファイルに検索対象の全シートをコピーしないと使えない。

それじゃ利便性が悪いので、
ブックの右端に「‡」という名前のシートを追加して、
結果を書き込むことにした。

このやり方、過去に作ったシート管理シート挿入マクロと同じ。
ブックの左端に「†」シートを追加して、ブック内のシート一覧を書き込むマクロ。


シート挿入系の処理は上記のマクロの流用。
左端を右端に変えただけ。

本来シート有無の判定は、全シートループをかける必要があるんだけど、
右端で使うという個人的ルールを順守することで省略した。

---

■処理の流れ

すでに「‡」シートがある場合は、削除する。
「‡」シートを挿入する。

InputBoxでキーワードを入力させ、
全シートループで、検索機能を使って検索をかける。

検索結果のセルが１つ目にHitした位置に戻ってきたら次のシートへ。

検索結果については、辞書型配列のItemsに‡で区切って格納。
（Hitしたセルに‡が含まれてるとアウトね。。。）

Itemsを２次元配列に格納し直して、
２次元配列から「‡」シートに貼り付け。

---

■改善点

今日作ったソースは突貫だったので、
昔作った検索する部分が怪しい。

検索ウィンドウのオプション状態（値で検索とか、大文字小文字とか）で
結果が左右されちゃうので検索条件は修正する必要があるな。

あと、検索結果へジャンプする機能も欲しいところ。
今後の課題ということで今日はここまで。

---

■ソース
ソースコードファイルは こちら。

Option Explicit

Sub キーワードを検索して出力()

Dim kw As String: kw = InputBox("ブック検索するキーワードを入力してください。", "キーワード入力")
If kw = "" Then errorEnd ("キーワードがないので終了します。")

'結果シートを挿入
Call addDobleDuggerSheet

' Dim tictoc As Double: Call ストップウォッチ(tictoc)

'結果格納用　辞書配列
Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")

'アクティブなブックを対象にキーワードを検索し、
Dim FoundCell As range, FirstCell As range, KeyWord As String, oGyo As Long
Dim sh As Long, cnt As Long
For sh = 1 To Worksheets.Count
Set FoundCell = Worksheets(sh).Cells.Find(What:=kw)
If Not (FoundCell Is Nothing) Then
Set FirstCell = FoundCell

'Hitしたら書き込む
cnt = cnt + 1
Dic.Add cnt, FoundCell.Parent.Name & "‡" & FoundCell.Address(0, 0) & "‡" & FoundCell.Value

Do
'次を検索
Set FoundCell = Worksheets(sh).Cells.FindNext(FoundCell)

'シートに１つしかなかったら抜ける
If FoundCell Is Nothing Then Exit Do

'検索結果が最初に戻ったら抜ける
If FoundCell.Address = FirstCell.Address Then Exit Do

'Hitしたら書き込む
cnt = cnt + 1
Dic.Add cnt, FoundCell.Parent.Name & "‡" & FoundCell.Address(0, 0) & "‡" & FoundCell.Value
Loop
End If
Next sh
''出力
Cells(1, "F") = "検索キーワード：" & kw

Dim oArr() As Variant: ReDim oArr(Dic.Count + 1, 4)
oArr(0, 0) = "№"
oArr(0, 1) = "シート"
oArr(0, 2) = "セル"
oArr(0, 3) = "テキスト"
Dim Items: Items = Dic.Items
Dim buf, i As Long
For i = 0 To Dic.Count - 1
oArr(i + 1, 0) = i + 1
buf = Split(Items(i), "‡")
oArr(i + 1, 1) = buf(0)
oArr(i + 1, 2) = buf(1)
oArr(i + 1, 3) = buf(2)
Next i
Set Dic = Nothing
Call ArrayToCell(Cells(1, 1), oArr)

Columns("D").ColumnWidth = 100
Cells(1, 1).AutoFilter
Cells(1, 1).CurrentRegion.Borders.LineStyle = xlContinuous

'ストップウォッチ (tictoc)
MsgBox "キーワード「" & kw & "」で検索した結果、" & Format(cnt, "#,##0") & "件ヒットしました。", vbOKOnly, Format(cnt, "#,##0") & "件ヒット"

End Sub





'2次元配列をシートに貼り付ける便利モジュール
Private Sub ArrayToCell(Target As range, oArr, Optional ColCnt As Long = 0)
Dim iRowMax: iRowMax = UBound(oArr, 1) - LBound(oArr, 1) + 1 '// １次元目の要素数を取得 '// 二次元配列の最大行数
Dim iColMax: iColMax = UBound(oArr, 2) - LBound(oArr, 2) + 1 '// ２次元目の要素数を取得'// 二次元配列の最大列数

'// Rangeオブジェクトで開始セルから貼り付けるセル範囲を拡張する場合
If ColCnt > 0 And ColCnt <= iColMax Then
Target.Resize(iRowMax, ColCnt).Value = oArr
Else
Target.Resize(iRowMax, iColMax).Value = oArr
End If
End Sub



Private Sub addDobleDuggerSheet()
'‡シートを挿入。すでにあれば確認のうえ上書き
If Worksheets(Worksheets.Count).Name = "‡" Then
If MsgBox("検索結果を更新しますか？", vbOKCancel) = vbCancel Then End
Application.DisplayAlerts = False
Worksheets(Worksheets.Count).Delete
Application.DisplayAlerts = True
End If
Sheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "‡"



End Sub

Private Sub ストップウォッチ(ByRef tictoc)
If tictoc = 0 Then
tictoc = Timer
Else
Debug.Print "[" & Now & "] "; Format(Timer - tictoc, "0.00秒")
tictoc = Timer
End If
End Sub

Private Sub errorEnd(msg)
MsgBox msg
End
End Sub