이 기사는 링크 정보 시스템 의 "2020 신춘 모험 달력 TechConnect! "릴레이 기사입니다.
TechConnect!는 마음대로 시작하는 어드벤트 캘린더로서 engineer.hanzomon이라는 마음대로 만든 그룹에 의해 릴레이됩니다.
링크 정보 시스템 Facebook은 여기

소개

업무중을 효율적으로 하기 위해서 사용하는 툴 「Excel」.
더 기능을 향상시키기 위해 VBA를 배울 수 있어요! 라고 생각해, 현재에 이릅니다.

구상

글쎄, 만지다고해도 무엇을 할까 ...
작성한다면 업무라든지 일상에서 사용할 수 있는 것이 좋다고 생각하면서 일하고 있었습니다.
그런 어느 날!
도형내(오토셰이프)의 문자를 검색해도 검출되지 않는다고 하는 일이 있었습니다.

아시다시피 Excel에는 매우 편리한 기능 "검색 · 바꾸기"가 있습니다. 그러나 기본 검색 대상은 셀 내에서만 가능하며 불행히도 도형의 문자를 감지하지 못합니다.
이대로는 Excel의 자료로, 도형내에 쓴 문자를 변경할 때 변경 누설 등의 인위적 실수가 생길지도 모릅니다.
그런 고민·문제를 조금이라도 없애고 싶어, 작성했습니다.

하고 싶은 일

하고 싶은 것은 단지 2개!
· Excel에서 도형의 문자 검색
· 검색한 문자 바꾸기

소스 코드

　이하, 작성한 소스 코드가 됩니다.
Copipe하면 움직일 것입니다!

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씨입니다!

링크 정보 시스템 에서는 함께 일하는 동료를 수시로 모집하고 있습니다.
또, 일의 의뢰, 비즈니스 파트너님도 모집하고 있습니다.
부담없이 연락 주시기 바랍니다.