'空白挿入で均等割付をする関数

'=MyKinto("(株)地球自転車",28,4) のように使います。
'28は空白挿入後の最大文字数（バイト）、4は挿入する空白の最大数（バイト）です。
'(株)などの部分には空白は挿入しません。
'MS ゴシックなどの固定ピッチフォントを設定してください。

Option Explicit

Function MyKinto(string1 As String, maxByteLength As Integer, _
        maxByteSpace As Integer) As String
    Dim i As Integer, j As Integer
    Dim spaceCount As Integer
    Dim s1 As String, s2 As String, sp As String
    Dim a() As Boolean

    '長さ0の文字列のチェック
    If Len(string1) = 0 Then
        MyKinto = ""
        Exit Function
    End If

    '空白挿入位置フラグの配列(a)の作成、空白挿入位置数(j)の計算、
    'かっこを半角にした文字列(s1)の作成
    ReDim a(1 To Len(string1))
    s1 = ""
    j = -1
    i = 1
    Do While i <= Len(string1)
        s2 = StrConv(Mid$(string1, i, 3), vbNarrow)
        If s2 Like "(?)" Then
            j = j + 1
            a(i) = True
            s1 = s1 & s2
            i = i + 3
        Else
            j = j + 1
            a(i) = False
            s1 = s1 & Mid$(string1, i, 1)
            i = i + 1
        End If
    Loop

    '空白挿入箇所が0の場合、挿入せずに返す
    If j = 0 Then
        MyKinto = s1
        Exit Function
    End If

    '挿入箇所1つ当たりの空白を作成
    spaceCount = (maxByteLength - myLenB(s1)) \ j
    If spaceCount > maxByteSpace Then
        sp = String(maxByteSpace, " ")
    Else
        sp = String(spaceCount, " ")
    End If

    '空白の挿入
    If a(1) Then
        s2 = Mid$(s1, 1, 3)
        i = 4
    Else
        s2 = Mid$(s1, 1, 1)
        i = 2
    End If
    Do While i <= Len(s1)
        If a(i) Then
            s2 = s2 & sp & Mid$(s1, i, 3)
            i = i + 3
        Else
            s2 = s2 & sp & Mid$(s1, i, 1)
            i = i + 1
        End If
    Loop
    MyKinto = s2
End Function

'文字列のバイト数を返す関数
Function myLenB(s As String) As Long
    myLenB = LenB(s)
End Function