« お祭り提灯 | Main | とりあえずSFTP »

【Excel VBA】シェイプ内の検索

Excelネタです。

先日、仕事でExcelに書かれたフローチャートを読んでいたのですが、複数のシートに大量に描画されていたので、見たいところを検索しようとしたら、検索できませんでした。
そういえば、Excelはシェイプの中の文字列は検索できないのでした。いろいろ調べてみましたが、どうも標準の機能だけでは検索できないようです。

Excel0

そこで、こんな感じでシェイプ限定で検索出来る機能を作ってみました。とりあえず、手元の資料を検索できるようにしただけなので、完ぺきではありませんが、結構便利です。

特に、開いているブックをすべて検索できるようにしたのがよかったかも。

Excel3

今後の課題として、正規表現とかも使えるようにしたいな。開いているブックを対象にする、セル検索バージョンも作ってみるのもいいな。

以下、作り方メモです。

まずは、VBAマクロの編集画面を起動して、ユーザーフォームを追加します。
[挿入]メニューから[ユーザー フォーム]で追加できます。

コントロールの配置は、こんな感じにします。フォームの名前は"frmSearchShapeText"にして、Captionは"シェイプ内テキスト検索"としました。

Form1

位置と大きさ以外のコントロールの設定は次の通り。

1) 切り替えタブ(TabSrtip)
 オブジェクト名 : tabModeSelect
 Height : 18
 TabFixedHeight : 15

 ※タブひとつひとつの設定は、タブを選択して、右クリックメニューから[名前の変更...]を選択します。
 「検索」タブ
  キャプション : "検索(D)"
  アクセスキー : "D"

 「置換」タブ
  キャプション : "置換(P)"
  アクセスキー : "P"

2) 「検索文字列」ラベル
 オブジェクト名 : lblPattern
 Accelerator : "N"
 Caption : "検索文字列(N) :"

3) 「検索文字列」テキストボックス
 オブジェクト名 : txtPattern

4) 「検索」ボタン
 オブジェクト名 : btnExecute
 Accelerator : "F"
 Caption : "検索(F)"

5) 「置換文字列」ラベル
 オブジェクト名 : lblReplace
 Accelerator : "E"
 Caption : "置換文字列(E) :"
 Visible : False

6) 「置換文字列」テキストボックス
 オブジェクト名 : txtReplace
 Visible : False

7) 「置換」ボタン
 オブジェクト名 : btnReplace
 Accelerator : "R"
 Caption : "置換(R)"
 Visible : False

8) 「検索範囲」ラベル
 オブジェクト名 : lblScope
 Accelerator : "S"
 Caption : "検索範囲(S) :"

9) 「検索範囲」コンボボックス
 オブジェクト名 : cmbScope
 Style : 2 - fmStyleDropDownList

10) 「大文字と小文字を区別する」チェックボックス
 オブジェクト名 : chkMatchCase
 Accelerator : "C"
 Caption : "大文字と小文字を区別する(C)"

11) 「内容が完全に同一あるものを検索する」チェックボックス
 オブジェクト名 : chkMatchExact
 Accelerator : "O"
 Caption : "内容が完全に同一あるものを検索する(O)"

12) 「全角と半角を区別する」チェックボックス
 オブジェクト名 : chkMatchByte
 Accelerator : "B"
 Caption : "全角と半角を区別する(B)"

コードは次の通り

Option Explicit

Private mCurWbIdx As Integer         '現在のワークブックのインデックス
Private mCurShIdx As Integer         '現在のワークシートのインデックス
Private mCurShpIdx As Integer        '現在のシェイプのインデックス
Private mStrConvParam As Integer     '変換パラメータ
Private mPatternText As String       '検索文字列
Private mReplaceText As String       '置換文字列
Private mIsReplaceMode As Boolean    '置換モードかどうか

'画面初期化
Private Sub UserForm_Initialize()
    mCurWbIdx = 1
    mCurShIdx = 1
    mCurShpIdx = 0
    mStrConvParam = 0
    mPatternText = ""
    mReplaceText = ""
    mIsReplaceMode = False

    '検索範囲を設定する
    cmbScope.AddItem "現在のワークシート"
    cmbScope.AddItem "現在のワークブック"
    cmbScope.AddItem "すべてのワークブック"
    cmbScope.ListIndex = 0
End Sub

'モード選択
Private Sub tabModeSelect_Change()
    Select Case tabModeSelect.value
    Case 0    '検索モード(置換コントロールは非表示)
        lblReplace.Visible = False
        txtReplace.Visible = False
        btnReplace.Visible = False
   
    Case 1    '置換モード(置換コントロールを表示)
        lblReplace.Visible = True
        txtReplace.Visible = True
        btnReplace.Visible = True
   
    End Select
   
End Sub

'検索パターンキー入力
Private Sub txtPattern_KeyDown( _
    ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Then
        '[Enter]キー入力で検索実行
        Call btnExecute_Click
    End If
End Sub

'検索ボタンクリック
Private Sub btnExecute_Click()
    mIsReplaceMode = False
    Call SearchMain
End Sub

'置換ボタンクリック
Private Sub btnReplace_Click()
    mIsReplaceMode = True
    Call SearchMain
End Sub

'検索主処理
Private Sub SearchMain()
    On Error GoTo ERR_FUNC
   
    Dim wb As Workbook      'ターゲットのワークブック
    Dim sh As Worksheet     'ターゲットのワークシート
    Dim isFound As Boolean  '見つかったかどうか
   
    Set wb = Workbooks(mCurWbIdx)
    isFound = False
   
    '検索文字列設定
    mStrConvParam = 0
    mPatternText = txtPattern.text
    If Len(mPatternText) = 0 Then
        MsgBox "検索文字列が指定されていません。", vbOKOnly, _
            "入力エラー"
        Exit Sub
    End If
    If chkMatchCase.value = False Then
        '大文字と小文字を区別しない場合
        mStrConvParam = mStrConvParam + vbLowerCase
    End If
    If chkMatchByte.value = False Then
        '全角と半角を区別しない場合
        mStrConvParam = mStrConvParam + vbNarrow
    End If
    If mStrConvParam > 0 Then
        '変換パラメータが設定された場合
        mPatternText = StrConv(mPatternText, mStrConvParam)
    End If
    If chkMatchExact.value = False Then
        '完全に同一でない場合は中間一致にする
        mPatternText = "*" & mPatternText & "*"
    End If
   
    '置換文字列設定
    mReplaceText = txtReplace.text
   
    '現在のブックが変わったらリセット
    If Not IsSameWorkBook(ActiveWorkbook, wb) Then
        mCurWbIdx = GetWorkbookIndex(ActiveWorkbook.Name)
        Set wb = Workbooks(mCurWbIdx)
        mCurShIdx = GetWorksheetIndex(wb.ActiveSheet.Name, wb.Name)
        If mCurShIdx < 0 Then
            mCurShIdx = 1
        End If
        mCurShpIdx = 0
    End If
   
    'スコープにより検索範囲を切り替え
    Select Case cmbScope.ListIndex
    Case 0  '現在のワークシート
        Set sh = wb.Worksheets(mCurShIdx)
        If ActiveSheet.Type = xlWorksheet Then
            If Not IsSameWorkSheet(ActiveSheet, sh) Then
                mCurShIdx = GetWorksheetIndex( _
                    wb.ActiveSheet.Name, wb.Name)
                mCurShpIdx = 0
            End If
        End If
        isFound = SearchInWorkSheet(sh, False)
       
    Case 1  '現在のワークブック
        isFound = SearchInWorkbook(wb, False)
   
    Case 2  'すべてのワークブック
        Dim i As Integer
        Dim idx As Integer
        idx = mCurWbIdx
        For i = 1 To Workbooks.Count
            If idx > Workbooks.Count Then
                idx = 1
            End If
            Set wb = Workbooks(idx)
            If SearchInWorkbook(wb, True) = True Then
                mCurWbIdx = idx
                isFound = True
                Exit For
            End If
            
            idx = idx + 1
        Next
    End Select
   
    '見つからなかった場合
    If Not isFound Then
        MsgBox "該当するシェイプが見つかりませんでした。"
    End If

    Exit Sub
   
ERR_FUNC:
    MsgBox Err.Number & ": " & Err.Description, vbOKOnly, _
        "例外エラー"

End Sub

'ワークブック内を検索する
Private Function SearchInWorkbook(_
        targetWb As Workbook, isAllBooks As Boolean) As Boolean
    SearchInWorkbook = False
   
    Dim i As Integer
    Dim idx As Integer
    Dim sh As Worksheet
   
    idx = mCurShIdx
    For i = 1 To targetWb.Worksheets.Count
        If idx > targetWb.Worksheets.Count Then
            idx = 1
            If isAllBooks Then
                mCurShIdx = 1
                Exit Function
            End If
        End If
       
        Set sh = targetWb.Worksheets(idx)
        If SearchInWorkSheet(sh, True) = True Then
            mCurShIdx = idx
            SearchInWorkbook = True
            Exit For
        End If
       
        idx = idx + 1
    Next
End Function

'ワークシート内を検索する

Private Function SearchInWorkSheet( _
        targetSh As Worksheet, isAllSheets As Boolean) As Boolean
    SearchInWorkSheet = False
   
    If targetSh Is Nothing Then Exit Function
    If targetSh.Visible <> xlSheetVisible Then Exit Function
    If Len(mPatternText) = 0 Then Exit Function
   
    Dim i As Integer
    Dim idx As Integer
    Dim shp As Shape
    Dim shpText As String
   
    idx = mCurShpIdx + 1
    For i = 1 To targetSh.Shapes.Count
        If idx > targetSh.Shapes.Count Then
            idx = 1
            If isAllSheets Then
                mCurShpIdx = 0
                Exit Function
            End If
        End If
       
        Set shp = targetSh.Shapes(idx)
        If MatchShapeText(shp) = True Then
            'シェイプを表示範囲に移動するためにシートとセルを
            '選択してから、シェイプを選択する

            targetSh.Activate
            shp.BottomRightCell.Select
            shp.TopLeftCell.Select
            shp.Select
            
            mCurShpIdx = idx
            AppActivate Me.Caption
            SearchInWorkSheet = True
            Exit For
        End If
       
        idx = idx + 1
    Next

End Function

'シェイプ内のテキストと検索パターンを比較する
Public Function MatchShapeText(targetShp As Shape) As Boolean
    MatchShapeText = False
   
    If targetShp.Type = msoGroup Then
        Dim subShp As Shape
        For Each subShp In targetShp.GroupItems
            If MatchShapeText(subShp) = True Then
                MatchShapeText = True
                Exit Function
            End If
        Next
    End If
            
    Dim shpText As String
    shpText = GetShapeText(targetShp)
    If mStrConvParam > 0 Then
        shpText = StrConv(shpText, mStrConvParam)
    End If
    If shpText Like mPatternText Then
        MatchShapeText = True
        If mIsReplaceMode Then
            '置換する場合
            Dim lookat As Integer
            Dim rng As Range
            Set rng = ThisWorkbook.Sheets(1).Cells("A1")
            rng = targetShp.TextFrame2.TextRange.text
            If chkMatchExact Then
                lookat = xlWhole
            Else
                lookat = xlPart
            End If
            Call rng.Replace(txtPattern.text, mReplaceText, _
                        lookat, xlByRows, _
                        chkMatchCase.value, chkMatchByte.value)
            targetShp.TextFrame2.TextRange.text = rng.Value2
            rng.Clear
        End If
    End If

End Function

'シェイプ内のテキスト取得する
Private Function GetShapeText(targetShp As Shape) As String
    On Error Resume Next
   
    GetShapeText = ""
   
    If targetShp.TextFrame2.HasText = msoTrue Then
        GetShapeText = targetShp.TextFrame2.TextRange.text
    End If
End Function

'同じワークブックかどうかを判定する
Public Function IsSameWorkBook( _
        x As Workbook, y As Workbook) As Boolean
    On Error GoTo ERR_FUNC
   
    IsSameWorkBook = False
   
    If x Is Nothing Then
        If y Is Nothing Then
            IsSameWorkBook = True
        End If
    Else
        If Not y Is Nothing Then
            'Excelで同じ名前のワークブックは開けないので、
            '名前で判断する。

            IsSameWorkBook = (x.FullName = y.FullName)
        End If
    End If
   
    Exit Function

ERR_FUNC:
    '何もしない
End Function

'同じワークシートかどうかを判定する
Public Function IsSameWorkSheet( _
        x As Worksheet, y As Worksheet) As Boolean
    On Error GoTo ERR_FUNC
   
    IsSameWorkSheet = False
   
    If x Is Nothing Then
        If y Is Nothing Then
            IsSameWorkSheet = True
        End If
    Else
        If Not y Is Nothing Then
            'Excelで同じ名前のワークシートは作れないので、
            '名前で判断する。

            IsSameWorkSheet = (x.Name = y.Name)
        End If
    End If
   
    Exit Function

ERR_FUNC:
    '何もしない
End Function

'指定のワークブックのインデックスを取得する
Public Function GetWorkbookIndex( _
        Optional workbookName As String) As Integer
    GetWorkbookIndex = -1
   
    'ワークブックの名前が指定されていない場合は、
    'アクティブなワークブックを対象にする

    If workbookName = "" Then
        If ActiveWorkbook Is Nothing Then Exit Function
        workbookName = ActiveWorkbook.Name
    End If
   
    '名前の一致するワークブックのインデックスを取得する
    Dim i As Integer
    For i = 1 To Workbooks.Count
        If workbookName = Workbooks(i).Name Then
            GetWorkbookIndex = i
            Exit Function
        End If
    Next
       
End Function

'指定のワークシートのインデックスを取得する
Public Function GetWorksheetIndex( _
        Optional worksheetName As String, _
        Optional workbookName As String) As Integer
    GetWorksheetIndex = -1
   
    'ワークブックのインデックスを取得する
    Dim wbIdx As Integer
    Dim wb As Workbook
    wbIdx = GetWorkbookIndex(workbookName)
    If wbIdx < 0 Then
        If ActiveSheet Is Nothing Then Exit Function
        wbIdx = GetWorkbookIndex(ActiveWorkbook.Name)
    End If
    Set wb = Workbooks(wbIdx)
   
    'ワークシートの名前が指定されていない場合は、
    'アクティブなワークシートを対象にする

    If worksheetName = "" Then
        worksheetName = wb.ActiveSheet.Name
    End If
   
    '名前の一致するワークシートのインデックスを取得する
    Dim i As Integer
    For i = 1 To wb.Worksheets.Count
        If worksheetName = wb.Worksheets(i).Name Then
            GetWorksheetIndex = i
            Exit Function
        End If
    Next
       
End Function

2013/11/14 追記

めんどくさがりさんにはこちらのフォームをVBAのエディタからインポートしてください。

「frmSearchShapeText.zip」をダウンロード

|

« お祭り提灯 | Main | とりあえずSFTP »

Comments

Post a comment



(Not displayed with comment.)




« お祭り提灯 | Main | とりあえずSFTP »