'検索と選択マクロ

'新規ブックのモジュールシートに以下のコードをコピーし、
'MakeDialog()を実行してダイアログシートを作成した後、
'FindAndSelectマクロを実行してください。

Option Explicit

Sub FindAndSelect()
    Const myTitle As String = "検索と選択"
    Dim range1 As Range, range2 As Range, r As Range
    Dim dlg1 As DialogSheet
    Dim obj As Object, xlApp As Object
    Dim cnt As Long
    Dim row1 As Long, col1 As Long
    Dim myWhat As String
    Dim myLookIn As Integer, mySearchOrder As Integer, myLookAt As Integer
    Dim myMatchCase As Boolean, myMatchByte As Boolean
    Dim myDisplayResult  As Boolean
    Dim errorNo As Integer

    Set dlg1 = ThisWorkbook.DialogSheets("FindSelectDialog")
    Set xlApp = Application

    '検索範囲の設定
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Cells.Count > 1 Then
        Set range1 = Application.Intersect( _
            Selection, ActiveSheet.UsedRange)
        If range1 Is Nothing Then
            MsgBox "選択範囲にデータはありません。", vbExclamation
            Exit Sub
        End If
    Else
        Set range1 = Selection.CurrentRegion
    End If
    range1.Select

    For Each obj In dlg1.DropDowns
        If obj.ListIndex = 0 Then obj.ListIndex = 1
    Next

    If Not (dlg1.Show) Then Exit Sub

    'Findメソッドの引き数の設定
    myWhat = dlg1.EditBoxes(1).Text
    Select Case dlg1.DropDowns(1).ListIndex
        Case 1
            mySearchOrder = xlByRows
        Case Else
            mySearchOrder = xlByColumns
    End Select
    Select Case dlg1.DropDowns(2).ListIndex
        Case 1
            myLookIn = xlFormulas
        Case 2
            myLookIn = xlValues
        Case Else
            myLookIn = xlNotes
    End Select
    With dlg1.CheckBoxes
        If .Item(1).Value = xlOn Then
            myMatchCase = True
        Else
            myMatchCase = False
        End If
        If .Item(2).Value = xlOn Then
            myMatchByte = True
        Else
            myMatchByte = False
        End If
        If .Item(3).Value = xlOn Then
            myLookAt = xlWhole
        Else
            myLookAt = xlPart
        End If
        If .Item(4).Value = xlOn Then
            myDisplayResult = True
        Else
            myDisplayResult = False
        End If
    End With

    On Error GoTo err_1
    Application.EnableCancelKey = xlErrorHandler
    Application.ScreenUpdating = False

    cnt = 0

    '1件目の検索
    With range1.Areas(range1.Areas.Count)
        Set r = .Cells(.Cells.Count)
    End With
    Set r = range1.Find(what:=myWhat, After:=r, _
        lookIn:=myLookIn, LookAt:=myLookAt, _
        searchOrder:=mySearchOrder, SearchDirection:=xlNext, _
        MatchCase:=myMatchCase, MatchByte:=myMatchByte)

    'Excel5.0ではFindメソッドにMatchByteパラメータがありませんので
    '上のステートメントを以下のものに置き換えてください。
    'Set r = range1.Find(what:=myWhat, After:=r, _
    '    lookIn:=myLookIn, LookAt:=myLookAt, _
    '    searchOrder:=mySearchOrder, SearchDirection:=xlNext, _
    '    MatchCase:=myMatchCase)

    If Not (r Is Nothing) Then

        '検索開始位置の設定
        row1 = r.Row
        col1 = r.Column

        Set range2 = r
        cnt = 1

        '検索のくり返し
        Set r = range1.FindNext(After:=r)
        Do Until (r.Row = row1) And (r.Column = col1)
            cnt = cnt + 1
            Set range2 = Application.Union(range2, r)
            Set r = range1.FindNext(After:=r)
        Loop
    End If

    If cnt > 0 Then range2.Select

    Application.ScreenUpdating = True
    If myDisplayResult Then
        MsgBox cnt & " 個のセルを選択しました。" & _
        Chr$(10) & "検索値: " & myWhat, vbInformation, myTitle
    End If
    Exit Sub
err_1:
    errorNo = Err
    xlApp.ScreenUpdating = True
    Select Case errorNo
        Case 18
            If Not (range2 Is Nothing) Then range2.Select
            If myDisplayResult Then
                MsgBox cnt & " 個のセルを選択しました。" & _
                    Chr$(10) & "検索値: " & myWhat, vbInformation, myTitle
            End If
            MsgBox "ユーザ操作により、処理が中断されました。", _
                vbExclamation, myTitle
        Case Else
            MsgBox Error(errorNo), vbExclamation, myTitle
    End Select
End Sub


Sub MakeDialog()
    Dim dlg As DialogSheet
    Dim gw As Double
    Set dlg = DialogSheets.Add
    With dlg
        .Name = "FindSelectDialog"
        gw = .Buttons(1).Height / 3
        .DialogFrame.Left = gw * 13
        .DialogFrame.Top = gw * 4
        .DialogFrame.Width = gw * 79
        .DialogFrame.Height = gw * 26
        .DialogFrame.Caption = "検索と選択"
        .DrawingObjects.Delete
    End With
    With dlg.Labels.Add(Left:=gw * 14, Top:=gw * 8, _
            Width:=gw * 23, Height:=gw * 3)
        .Accelerator = "n"
        .Caption = "検索する文字列"
    End With
    With dlg.EditBoxes.Add(Left:=gw * 14, Top:=gw * 11, _
            Width:=gw * 67, Height:=gw * 3)
    End With
    With dlg.Labels.Add(Left:=gw * 14, Top:=gw * 17, _
            Width:=gw * 11, Height:=gw * 3)
        .Accelerator = "s"
        .Caption = "検索方向"
    End With
    With dlg.DropDowns.Add(Left:=gw * 26, Top:=gw * 17, _
            Width:=gw * 20, Height:=gw * 3)
        .DropDownLines = 3
        .AddItem "行"
        .AddItem "列"
        .ListIndex = 1
    End With
    With dlg.Labels.Add(Left:=gw * 14, Top:=gw * 23, _
            Width:=gw * 11, Height:=gw * 3)
        .Accelerator = "l"
        .Caption = "対象"
    End With
    With dlg.DropDowns.Add(Left:=gw * 26, Top:=gw * 23, _
            Width:=gw * 20, Height:=gw * 3)
        .DropDownLines = 3
        .AddItem "数式"
        .AddItem "値"
        .AddItem StrConv("メモ", vbNarrow)
        .ListIndex = 1
    End With
    With dlg.CheckBoxes.Add(Left:=gw * 48, Top:=gw * 16, _
            Width:=gw * 33, Height:=gw * 3)
        .Accelerator = "c"
        .Caption = "大文字と小文字を区別する"
    End With
    With dlg.CheckBoxes.Add(Left:=gw * 48, Top:=gw * 19, _
            Width:=gw * 33, Height:=gw * 3)
        .Accelerator = "b"
        .Caption = "半角と全角を区別する"
    End With
    With dlg.CheckBoxes.Add(Left:=gw * 48, Top:=gw * 22, _
            Width:=gw * 33, Height:=gw * 3)
        .Accelerator = "o"
        .Caption = StrConv("完全に同一なセルだけを検索する", vbNarrow)
    End With
    With dlg.CheckBoxes.Add(Left:=gw * 48, Top:=gw * 25, _
            Width:=gw * 33, Height:=gw * 3)
        .Accelerator = "r"
        .Caption = "検索件数を表示する"
        .Value = xlOn
    End With
    With dlg.Buttons.Add(Left:=gw * 82, Top:=gw * 8, _
            Width:=gw * 9, Height:=gw * 3)
        .Caption = "OK"
        .DismissButton = True
        .DefaultButton = True
    End With
    With dlg.Buttons.Add(Left:=gw * 82, Top:=gw * 12, _
            Width:=gw * 9, Height:=gw * 3)
        .Caption = StrConv("キャンセル", vbNarrow)
        .CancelButton = True
    End With
End Sub