'A列を検索するツールバー(Excel97)

'標準モジュールに以下のコードをコピーし、MakeFindBar
'マクロを実行してツールバーを作成してください。
'作成されたツールバーは一時的なもので、Excel終了時に
'自動的に削除されます。

Option Explicit

Private Const sBarName As String = "A列の検索"
Private Const sTarget As String = "A:A"
Private Const iMaxListCount As Integer = 10

'検索ツールバーを作成するマクロ
Sub MakeFindBar()
    Dim oCommandBar As CommandBar

    On Error GoTo ErrorHandler

    '既存のツールバーをチェック
    Set oCommandBar = GetItemByName(CommandBars, sBarName)
    If Not (oCommandBar Is Nothing) Then
        oCommandBar.Visible = True
        MsgBox "すでに同名のツールバーがあります。", _
            vbExclamation, sBarName
        Exit Sub
    End If

    'ツールバーの作成
    '永続的なツールバーを作成するにはTemporaryをFalseにします。
    With CommandBars.Add(Name:=sBarName, Temporary:=True)

        'コンボボックスの作成
        With .Controls.Add(Type:=msoControlComboBox)
            .Width = 160
            .OnAction = "FindCombo_Action"
        End With

        .Visible = True
    End With
    Exit Sub
ErrorHandler:
    MsgBox Error(Err), vbExclamation, sBarName
End Sub

Function GetItemByName(ByVal oCollection As Object, _
        ByVal sItemName As String) As Object
    Set GetItemByName = Nothing
    On Error Resume Next
    Set GetItemByName = oCollection.Item(sItemName)
    On Error GoTo 0
End Function

'コンボボックスに登録するマクロ
Sub FindCombo_Action()
    Dim oRange_Target As Range
    Dim oComboBox As CommandBarComboBox
    Dim sText As String
    Dim r As Range
    Dim i As Integer

    On Error GoTo ErrorHandler

    '検索対象範囲の設定
    Set oRange_Target = ActiveSheet.Range(sTarget)

    'ComboBoxの設定
    Set oComboBox = CommandBars(sBarName).Controls(1)

    'ComboBoxのテキストの取得
    sText = oComboBox.Text

    '既にリストにあれば削除
    For i = 1 To oComboBox.ListCount
        If oComboBox.List(i) = sText Then
            oComboBox.RemoveItem i
            Exit For
        End If
    Next

    'リスト項目が最大数になったら最後の1つを削除
    If oComboBox.ListCount >= iMaxListCount Then
        oComboBox.RemoveItem iMaxListCount
    End If

    'リストへ項目を追加
    oComboBox.AddItem sText, 1

    oComboBox.ListIndex = 1

    '検索開始セルの取得
    'アクティブセルが検索対象範囲にない場合は
    '検索対象範囲の最後のセルにします
    If Application.Intersect(oRange_Target, ActiveCell) Is Nothing Then
        Set r = oRange_Target.Cells(oRange_Target.Cells.Count)
    Else
        Set r = ActiveCell
    End If

    '検索の実行
    '必要に応じてオプションを設定してください
    Set r = oRange_Target.Find(what:=sText, _
        after:=r, LookIn:=xlFormulas, LookAt:=xlWhole, _
        SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
        MatchCase:=False, MatchByte:=False)

    If r Is Nothing Then
        MsgBox "見つかりません。", vbExclamation, sBarName
        Exit Sub
    Else
        r.Activate
    End If

    Exit Sub

ErrorHandler:
    MsgBox Error(Err), vbExclamation, sBarName
End Sub