この記事は リンク情報システム の「2020新春アドベントカレンダー TechConnect!」のリレー記事です。
TechConnect! は勝手に始めるアドベントカレンダーとして、engineer.hanzomon という勝手に作ったグループによってリレーされます。
リンク情報システムのFacebookはこちらから
#はじめに
業務中を効率良くするために使用するツール**「Excel」**。
さらに機能を向上するためにVBAを学習がてら触ってみよう！と思い、現在に至ります。
#構想
さてさて、触るといっても何をしようかと...
作成するなら業務とか日常で使えるものがいいなぁと考えながら働いていました。
そんなある日！
図形内(オートシェイプ)の文字を検索しても、検出されないということがありました。
ご存じの通りのExcelにはとても便利な機能「検索・置換」があります。しかし、デフォルトの検索対象はセル内のみであり、残念なことに図形内の文字は検出してくれません...
このままではExcelの資料で、図形内に書き込んだ文字を変更する時に変更漏れ等の人為的ミスが生じるかもしれません。
そのような悩み・問題を少しでも無くしたいと思い、作成しました。
#やりたいこと
やりたいことはただ2つ！
・Excelから図形内の文字を検索
・検索した文字を置換
#ソースコード
以下、作成したソースコードとなります。
コピペすれば動くはずです！
Option Explicit
'ポップアップの名前
Private Const TITLE_SEARCH_SHAPE_TEXT As String = "オートシェイプ検索"
'@brief : 文字検索関数
'@return : なし
Public Sub searchShapeText()
Dim sheet As Worksheet 'ワークシート
Dim searchWord As String '検索ワード
'検索ワード入力ポップアップを表示する
searchWord = InputBox("検索したいワードを入力して下さい", TITLE_SEARCH_SHAPE_TEXT)
If searchWord = "" Then
GoTo ExitSub
End If
'対象のワークシートを現在開いているシートとする
Set sheet = ActiveSheet
'検索ワードが見つからない場合に出力
If Not (searchReplaceShapeText(sheet.Shapes, searchWord)) Then
MsgBox "「" & searchWord & "」が見つかりません", vbExclamation, TITLE_SEARCH_SHAPE_TEXT
End If
ExitSub:
End Sub
'@brief : 図形内検索置換関数
'@param : worksheetObject Worksheetオブジェクト
'@param : searchWord 検索文字
'@return: searchReplaceShapeText 処理継続判定
Private Function searchReplaceShapeText(ByVal worksheetObject As Object, ByVal searchWord As String) As Boolean
Dim targetShape As Shape 'ワークシート内の図形
Dim shapeText As String '図形内の文字
Dim discoveryWord As Long '検索ワード発見位置
Dim replaceWord As String '置換後の文字
Dim replacePopupMsg As String '置換ポップアップメッセージ
Dim ret As Boolean '処理継続判定
Dim searchWordCnt As Long: searchWordCnt = 1 '図形内検索ワード数
ret = False
'ワークシートに図形が存在する間ループ
For Each targetShape In worksheetObject
'クループ化された図形の時
If (targetShape.Type = msoGroup) Then
If (searchReplaceShapeText(targetShape.GroupItems, searchWord)) Then
ret = True
GoTo ExitFunction
End If
'コメントの時
ElseIf (targetShape.Type = msoComment) Then
GoTo CONTINUE
Else
'指定したテキストフレームにテキストがあるかどうかを返す
If (targetShape.TextFrame2.HasText = msoTrue) Then
'図形内のテキストを取得
shapeText = targetShape.TextFrame2.TextRange.Text
'図形内の文字列から検索
discoveryWord = InStr(shapeText, searchWord)
'検索ワードが見つかったとき、置換の処理を行う
If (discoveryWord > 0&) Then
'ウィンドウを図形の位置にスクロール
ActiveWindow.ScrollRow = targetShape.TopLeftCell.Row
ActiveWindow.ScrollColumn = targetShape.TopLeftCell.Column
Do While (discoveryWord > 0&)
'テキスト範囲選択を解除するため、カレントセルを選択する
targetShape.TopLeftCell.Select
targetShape.TextFrame2.TextRange.Characters(discoveryWord, Len(searchWord)).Select
replacePopupMsg = "置換する場合、入力してください。" & vbCr & vbCr & "置換前 : " & searchWord & vbCr & "置換後"
' 置換入力メッセージを出力する
replaceWord = InputBox(replacePopupMsg, "置換")
If replaceWord = "" Then
ret = True
GoTo CONTINUE
End If
'図形内の文字列を置換する
targetShape.TextFrame2.TextRange.Text = Replace(shapeText, searchWord, replaceWord, 1, searchWordCnt)
targetShape.TopLeftCell.Select
'もう一度検索・置換するのか
If (MsgBox("continue?", vbQuestion Or vbOKCancel, TITLE_SEARCH_SHAPE_TEXT) <> vbOK) Then
ret = True
GoTo CONTINUE
'同じ図形内で文字検索
Else
discoveryWord = InStr(discoveryWord + 1&, shapeText, searchWord)
End If
searchWordCnt = searchWordCnt + 1
Loop
GoTo CONTINUE
End If
End If
End If
CONTINUE:
Next
ExitFunction:
searchReplaceShapeText = ret
ExitSub:
End Function
#使用方法
今回は例としてワークシート上に【検索・置換ボタン】を作成しました。
(ショートカットキーやクイックアクセスツールバーに登録すると使いやすいかと思います。)
##検索
1.検索・置換ボタンを押します。
2.検索ワードを入力します。
・Enterキーもしくは[OK]をクリックすると検索が開始します。
・[×]もしくは[キャンセル]をクリックすると終了します。
・図形内に無い文字を入力すると警告文が出力され終了します。
※セル内の文字は検索対象ではありません
##検索結果/置換ワード入力
1.検索ワードが見つかると対象の図形にジャンプし、置換のメッセージが表示されます。
2.置換後のボックスに置換後の文字を入力します。
・Enterキーもしくは[OK]をクリックすると図形内の対象の文字が置換されます。
・[×]もしくは[キャンセル]をクリックすると終了します。
##再検索
1.置換完了後に再度同じワードを検索・置換するかを問うメッセージが出力されます。
・Enterキーもしくは[OK]をクリックすると検索が開始します。
・[×]もしくは[キャンセル]をクリックすると終了します。
2-1.検索文字がさらに見つかった場合は「検索結果/置換ワード入力」の状態に戻ります。
2-2.見つからない場合は警告文が出力され終了します。
#今後の展望
マルチページの機能を使って検索置換のタブ化
検索結果のマーク付け
(できたらいいなぁ...)
#まとめ
まだまだ改良できる点は多いですが、色々と参考にさせていただき、なんとか使えるくらいには作成できました！
明日は@r-kanaiさんです！
リンク情報システム では一緒に働く仲間を随時募集しています。
また、お仕事のご依頼、ビジネスパートナー様も募集しております。
お気軽にご連絡ください。