Sub search_and_fontstylechange()            '2003/11/30 指定した文字列を検索し、その文字だけに書式を設定する。
'
    Dim i As Long
    Dim tmpValue As Variant
    Dim response As Integer
    Dim tmpRange As Range
    Dim tmpCount As Long

    Dim search_char As String
    Dim search_char_len As Long
    Dim start_pos As Long

    Dim tmpColorIndex As Long
    Dim flgBold As Boolean
    Dim flgItalic As Boolean
    Dim tmpUnderLine As Variant
    Dim flgStrikethrough As Boolean
    Dim tmpFontStyle As String
    Dim arColorIndex As Variant
    arColorIndex = Array(0, 1, 2, 3, 4, 5, 6, 7, 8, 9, _
                        10, 11, 12, 13, 14, 15, 16, _
                        33, 34, 35, 36, 37, 38, 39, _
                        40, 41, 42, 43, 44, 45, 46, 47, 48, 49, _
                        50, 51, 52, 53, 54, 55, 56)
    tmpColorIndex = -1
    flgBold = False
    flgItalic = False
    flgStrikethrough = False
    tmpUnderLine = xlUnderlineStyleNone

                                                'シートが保護されているとこのマクロはエラーが発生する
    For Each tmpRange In ActiveSheet.UsedRange  'UsedRangeは使用している範囲全体が全て選択される
        If Not IsError(tmpRange.Value) Then     '#VALUE!や#DIV/0!などのエラーがあるとValueが参照できない
            If tmpRange.Value <> "" Then
                tmpCount = tmpCount + 1
            End If
        End If
    Next
    If tmpCount = 0 Then
        response = MsgBox("文字・数値が入力されているセルがありません", vbOKOnly + vbCritical, "エラー")
        Exit Sub
    End If

    search_char = InputBox("書式設定したい文字列を入力してください", "検索文字の指定")
    search_char_len = Len(search_char)
    If search_char_len = 0 Then
        Exit Sub
    End If

    Do While tmpColorIndex = -1
        tmpValue = InputBox("検索文字に設定する色を次の中から数字で指定してください" & vbCr & vbCr & _
                            "0:自動 , 1:黒 , 2:白 , 3:赤 , 4:明るい緑 , 5:青 , 6:黄 ," & vbCr & _
                            "7:ピンク , 8:水色 , 9:濃い赤 , 10:緑 , 11:濃い青 , 12:濃い黄 ," & vbCr & _
                            "13:紫 , 14:青緑 , 15:25%灰色 , 16:50%灰色 , 33:スカイブルー ," & vbCr & _
                            "34:薄い水色 , 35:薄い緑 , 36:薄い黄 , 37:ペールブルー ," & vbCr & _
                            "38:ローズ , 39:ラベンダー , 40:ベージュ , 41:薄い青 ," & vbCr & _
                            "42:アクア , 43:ライム , 44:ゴールド , 45:薄いオレンジ ," & vbCr & _
                            "46:オレンジ , 47:ブルーグレー , 48:40%灰色 , 49:濃い青緑 ," & vbCr & _
                            "50:シーグリーン , 51:濃い緑 , 52:オリーブ , 53:茶 ," & vbCr & _
                            "54:プラム , 55:インディゴ , 56:80%灰色", "文字色の指定", 0)
        If IsNumeric(tmpValue) Then
            For i = 1 To 41                                             'option base 1 が前提
                If Val(tmpValue) = arColorIndex(i) Then
                    tmpColorIndex = Val(tmpValue)
                    Exit For
                End If
            Next
        End If
    Loop

    response = MsgBox("検索文字を<太字>にしますか？", _
                vbYesNoCancel + vbQuestion + vbDefaultButton2, "書式")
    If response = vbYes Then
        flgBold = True
    Else
        If response = vbCancel Then
            Exit Sub
        End If
    End If
    response = MsgBox("検索文字を<斜体>にしますか？", _
                vbYesNoCancel + vbQuestion + vbDefaultButton2, "書式")
    If response = vbYes Then
        flgItalic = True
    Else
        If response = vbCancel Then
            Exit Sub
        End If
    End If
    response = MsgBox("検索文字に<下線>を付けますか？", _
                vbYesNoCancel + vbQuestion + vbDefaultButton2, "書式")

    '下線にはSingle,Double,各会計用の4種類あるが、今回はsingle下線のみ
    If response = vbYes Then
        tmpUnderLine = xlUnderlineStyleSingle
    Else
        If response = vbCancel Then
            Exit Sub
        End If
    End If
    response = MsgBox("検索文字に<取り消し線>を付けますか？", _
                vbYesNoCancel + vbQuestion + vbDefaultButton2, "書式")
    If response = vbYes Then
        flgStrikethrough = True
    Else
        If response = vbCancel Then
            Exit Sub
        End If
    End If

    tmpFontStyle = "標準"
    If flgBold Then
        tmpFontStyle = "太字"
        If flgItalic Then
            tmpFontStyle = "太字 斜体"
        End If
    Else
        If flgItalic Then
            tmpFontStyle = "斜体"
        End If
    End If

    tmpCount = 0
    start_pos = 0
    For Each tmpRange In ActiveSheet.UsedRange
        If Not IsError(tmpRange.Value) Then  '#VALUE!や#DIV/0!などのエラーがあるとValueが参照できない
            start_pos = InStr(1, tmpRange.Value, search_char, 0)
            Do While start_pos > 0
                tmpRange.Select
                With ActiveCell.Characters(Start:=start_pos, Length:=search_char_len).Font
                    .ColorIndex = tmpColorIndex
                    .Underline = tmpUnderLine
                    .Strikethrough = flgStrikethrough
                    .FontStyle = tmpFontStyle
                End With
                tmpCount = tmpCount + 1
                start_pos = InStr(start_pos + Len(search_char), tmpRange.Value, search_char, 0)
            Loop
        End If
    Next

    response = MsgBox(tmpCount & " 箇所に書式を設定しました。", _
                                    vbOKOnly + vbInformation, "処理終了")
'
End Sub