-
Notifications
You must be signed in to change notification settings - Fork 0
/
searchWordInShape.txt
95 lines (75 loc) · 3.55 KB
/
searchWordInShape.txt
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
' 検索文字列
Private searchStr As String
' 検索結果出力時の出力先セルのカウンタ変数
Private outputCount As Integer
' 検索結果出力シート名
Const searchResultOutputSheetName = "検索結果"
' オブジェクト内の文字列を検索する
Sub searchWordInShape()
outputCount = 1
searchStr = InputBox("検索文字列を入力してください")
' ブック内のシート分ループ
For Each targetSheet In ActiveWorkbook.Sheets
Dim parentShape As Shape
' シート内のオートシェイプでループ
For Each parentShape In targetSheet.Shapes
Dim text As String
' オートシェイプがグループ化されている場合
If parentShape.Type = msoGroup Then
Dim groupedShape As Shape
' グループ化されているオートシェイプでループ
For Each groupedShape In parentShape.GroupItems
text = groupedShape.TextFrame.Characters.text
If InStr(text, searchStr) > 0 Then
' オートシェイプの文字列に検索文字がある場合
outputSearchResult targetSheet.Name, text, groupedShape
End If
Next groupedShape
' オートシェイプがグループ化されていない場合
Else
text = parentShape.DrawingObject.Characters.text
If InStr(text, searchStr) > 0 Then
' オートシェイプの文字列に検索文字がある場合
outputSearchResult targetSheet.Name, text, parentShape
End If
End If
Next parentShape
Next targetSheet
End Sub
' 検索結果の出力を行う
' linkTargetSheetName 検索結果の対象が存在するシート名
' displayString 検索結果の文字列
' linkTargetShape ヒットしたオートシェイプ
Sub outputSearchResult(linkTargetSheetName As String, displayString As String, linkTargetShape As Shape)
If outputCount = 1 Then
If existsSheet(searchResultOutputSheetName) Then
' 検索結果を出力するシートがすでに存在する場合シートを削除する
Application.DisplayAlerts = False
Worksheets(searchResultOutputSheetName).Delete
Application.DisplayAlerts = True
End If
' 検索結果を出力するシートの作成
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = searchResultOutputSheetName
End If
' 検索結果を出力するシートをアクティブにする
Worksheets(searchResultOutputSheetName).Activate
' 検索結果の出力
ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & outputCount), Address:="", SubAddress:=linkTargetSheetName & "!" & linkTargetShape.TopLeftCell.Address, TextToDisplay:=searchStr
outputCount = outputCount + 1
End Sub
' シートの存在チェック
' SheetName チェックするシート名
Public Function existsSheet(SheetName As String) As Boolean
Dim result As Boolean
result = False
' ブック内のシート分ループ
For Each targetSheet In ActiveWorkbook.Sheets
If targetSheet.Name = SheetName Then
' チェック対象のシートが存在した場合
result = True
Exit For
End If
Next
existsSheet = result
End Function