'書式コマンドを使い、セルの文字列を書式化するマクロ


'セルの文字列を以下の書式コマンドに従って書式化します。

'^^   次の1文字を上付きにする
'^^*  以降の文字をすべて上付きにする
'..   次の1文字を下付きにする
'..*  以降の文字をすべて下付きにする
'::   次の1文字を標準にする
'::*  以降の文字をすべて標準にする


'独自の書式コマンドを定義するには、変数vCommandにコマンド文字列の
'配列を設定し、コマンド別の処理を記述してください。
'配列変数iCommandNoは、変数vCommandに設定されたときのコマンドの
'順番を示します。（0が先頭です。）

Option Explicit

Sub MyCharactersFormat()
    Dim vCommand As Variant
    Dim sCommand() As String
    Dim iCommandMax As Integer
    Dim iCommandNo() As Integer
    Dim iCommandLength() As Integer
    Dim iTmp As Integer
    Dim sTmp As String
    Dim iLength As Integer
    Dim vText As Variant
    Dim sText As String
    Dim r As Range
    Dim i As Integer, j As Integer

    'コマンド文字列の定義
    '上付き、すべて上付き、下付き、すべて下付き、標準、すべて標準
    vCommand = Array("^^", "^^*", "..", "..*", "::", "::*")

    'コマンド文字列を配列に格納
    iCommandMax = UBound(vCommand) - LBound(vCommand)
    ReDim sCommand(0 To iCommandMax)
    ReDim iCommandLength(0 To iCommandMax)
    ReDim iCommandNo(0 To iCommandMax)
    j = 0
    For i = LBound(vCommand) To UBound(vCommand)
        iCommandNo(j) = j
        sCommand(j) = vCommand(i)
        iCommandLength(j) = Len(sCommand(j))
        j = j + 1
    Next

    'コマンド文字列の長さの降順に並び替える
    For i = 0 To iCommandMax - 1
        For j = i + 1 To iCommandMax
            If iCommandLength(j) > iCommandLength(i) Then
                iTmp = iCommandLength(i)
                iCommandLength(i) = iCommandLength(j)
                iCommandLength(j) = iTmp
                iTmp = iCommandNo(i)
                iCommandNo(i) = iCommandNo(j)
                iCommandNo(j) = iTmp
                sTmp = sCommand(i)
                sCommand(i) = sCommand(j)
                sCommand(j) = sTmp
            End If
        Next
    Next

    For Each r In Selection.Cells
        If Not (r.HasFormula) Then
            vText = r.Value
            If VarType(vText) = vbString Then
                sText = vText
                iLength = Len(sText)
                If iLength = 0 Then
                    r.ClearContents
                Else
                    i = 1
                    Do While i <= iLength
                        For j = 0 To iCommandMax
                            If Mid$(sText, i, iCommandLength(j)) = sCommand(j) Then

                                'コマンド文字列の削除
                                r.Characters(i, iCommandLength(j)).Delete
                                iLength = iLength - iCommandLength(j)
                                sText = Left$(sText, i - 1) & Mid$(sText, i + iCommandLength(j))

                                'コマンド別の処理
                                'iCommandNoは最初に定義したコマンドの順番です
                                Select Case iCommandNo(j)

                                    '上付き
                                    Case 0
                                        r.Characters(i, 1).Font.Superscript = True

                                    'すべて上付き
                                    Case 1
                                        r.Characters(i).Font.Superscript = True
                                        i = iLength

                                    '下付き
                                    Case 2
                                        r.Characters(i, 1).Font.Subscript = True

                                    'すべて下付き
                                    Case 3
                                        r.Characters(i).Font.Subscript = True
                                        i = iLength

                                    '標準
                                    Case 4
                                        r.Characters(i, 1).Font.Superscript = False
                                        r.Characters(i, 1).Font.Subscript = False

                                    'すべて標準
                                    Case 5
                                        r.Characters(i).Font.Superscript = False
                                        r.Characters(i).Font.Subscript = False
                                        i = iLength

                                End Select
                                Exit For
                            End If
                        Next
                        i = i + 1
                    Loop
                End If
            End If
        End If
    Next
End Sub