トップ　>　汎用コード　>　セル内の任意の文字列を上付き文字または下付き文字に設定

'------------------------------------------------------------------------------
' 実行用マクロ
'------------------------------------------------------------------------------
Sub 選択セル範囲から任意の文字列を検索し上付きまたは下付き文字にする()
    
    ' 検索文字列
    Const L_WHAT As String = "※" ' 検索文字列はここで設定

    ' テスト文字列　使用の場合は次の3行の先頭にある「'」を削除する
'    Range("A1:D1").Value = Array("東京都千代田区※", "東京都台東区※", "注釈※", "※※")
'    Range("A1:D1").EntireColumn.AutoFit
'    Range("A1:D1").Select
    
    ' 選択しているオブジェクトがセルでなければ抜ける
    If TypeName(Application.Selection) <> "Range" Then
        MsgBox "対象のセル範囲を選択してください", vbInformation, "終了します"
        Exit Sub
    End If
    
    ' Rangeオブジェクトに選択セル範囲を設定
    Dim rngTarget As Range
    Set rngTarget = Application.Selection
    
    Dim strMessage As String
    '《セル内の任意の文字列を上付き文字または下付き文字に設定》
    ' ** 引数1：検索対象セル範囲
    ' ** 引数2：検索文字列
    ' ** 引数3：上付き文字の設定　True：上付き文字　False：下付き文字（省略可　既定：True）
    ' ** 引数4：各セル内で検索を開始する文字の位置（省略可　既定：1）
    ' ** 引数5：各セル内で上付きまたは下付きを設定する回数(省略可　既定:0:制限なし)）
    '   戻り値：成功：空の文字列　失敗：エラーメッセージ
    strMessage = setSuperscriptForCharacters(rngTarget, L_WHAT)

    ' 結果メッセージ
    If strMessage = "" Then
        MsgBox "実行完了しました。", vbInformation
    Else
        MsgBox strMessage, vbExclamation
    End If
End Sub

'---------------------------------------------------------------------------
' セル内の任意の文字列を上付き文字または下付き文字に設定
'---------------------------------------------------------------------------
'［引数］
'   rngTarget  ：検索対象セル範囲
'   What       ：検索文字列
'   Superscript：上付き文字の設定　True：上付き文字　False：下付き文字
'   Start      ：各セル内で検索を開始する文字の位置（既定：1）
'   Times      ：各セル内で上付きまたは下付きを設定する回数(既定:0:制限なし)
'［戻り値］
'   成功：空の文字列　エラー：エラーメッセージ
'［作成日］2023.06.09　［更新日］2025.03.14
' https://excel.syogyoumujou.com/vba/set_charactersfontsuperscript.html
'---------------------------------------------------------------------------
Function setSuperscriptForCharacters(ByRef rngTarget As Range, _
                                     ByVal What As String, _
                            Optional ByVal Superscript As Boolean = True, _
                            Optional ByVal Start As Long = 1, _
                            Optional ByVal Times As Long = 0) As String
                      
On Error GoTo LBL_ERROR

    ' 検索文字列が空の場合は抜ける
    If What = "" Then
        setSuperscriptForCharacters = "検索文字列がありません"
        Exit Function
    End If

    Dim strAddress  As String    ' セルアドレス格納用
    Dim lngStart    As Long      ' 検索スタート位置設定用
    Dim lngPosition As Long      ' テキスト内の検索文字列位置格納用
    Dim lngTimes    As Long      ' テキスト内での色設定回数 (セル毎)
    Dim lngLen      As Long      ' 検索文字列の長さ格納用
    Dim rngFind     As Range     ' 検索用

    ' 検索文字列の文字数取得
    lngLen = Len(What)

    '------------------------
    ' 対象セル範囲検索
    '------------------------
    ' 対象セル範囲から任意の文字列を含むセルを検索
    Set rngFind = rngTarget.Find(What, , xlValues, xlPart, xlByRows, , False, False)
    
    ' 検索に一致のセルがない場合
    If rngFind Is Nothing Then
        ' ※ 結合セルで検索に一致しないケースがあるため その対策処理
        Set rngFind = rngTarget.Find(What, , xlValues, xlPart, xlByColumns, , False, False)
        
        ' 検索に一致のセルがない場合はプロシージャを抜ける
        If rngFind Is Nothing Then
            setSuperscriptForCharacters = "対象の文字列はありません"
            Exit Function
        End If
    End If

    ' 最初に一致したセルのアドレスを取得
    strAddress = rngFind.Address

    '------------------------
    ' セル内テキスト検索
    '------------------------
    Do
        lngStart = Start
        lngTimes = 0
        
        Do
            ' テキストを検索
            lngPosition = InStr(lngStart, rngFind.Value, What, vbTextCompare)

            ' テキスト内に検索文字列が見つからなかったら抜ける
            If lngPosition = 0 Then Exit Do

            If Superscript Then
                ' 対象文字列を上付き文字に設定
                rngFind.Characters(lngPosition, lngLen).Font.Superscript = True
            Else
                ' 対象文字列を下付き文字に設定
                rngFind.Characters(lngPosition, lngLen).Font.Subscript = True
            End If
            lngTimes = lngTimes + 1

            ' 指定した設定回数に到達したら抜ける
            If lngTimes = Times Then Exit Do

            ' 検索スタート位置を再設定
            lngStart = lngPosition + lngLen
        Loop

        ' 対象セル範囲内で次の検索一致セルを検索
        Set rngFind = rngTarget.FindNext(rngFind)

        ' セルアドレスが変数のアドレスと一致 またはセルを取得できない場合はループを抜ける
    Loop Until strAddress = rngFind.Address Or rngFind Is Nothing
    
    Exit Function

'------------------------
' エラー処理
'------------------------
LBL_ERROR:
    setSuperscriptForCharacters = "エラーが発生しました" & vbLf & _
                                  "エラー番号:" & Err.Number & vbLf & _
                                  Err.Description
    Err.Clear
End Function