氏名を7文字に揃えるVBScript（含む：IPAmj明朝）
heijou tomateExcel で名簿を作るときなど、「氏名の左右をピタっと揃えられたら綺麗だよね」という方もいらっしゃるようで、それも流儀がいろいろあります。
ここでは、日本人では多数派の『姓2文字＋名2文字』の場合は各文字の間に半角か全角のスペースを入れて7文字にそろえることを基本に、姓と名の間のスペースと、姓の文字間や名の文字間を調整して、縦に並べると姓名の両端が揃うようにすることを考えます。
例として、歴代首相(10人)の名簿を変換してみました。
ExcelマクロやVBScriptで、MS明朝やMSゴシック時代でも同様のツールを作っていたのですが、問題はこれらの従来の書体に含まれない外字の扱いです。
IPAmj明朝のコードから見た外字の種類
2011年10月に公開された『IPAmj明朝明朝』では、外字2バイト文字ではなくて4バイト・6バイト・8バイト・12バイトの3種類があり、Excelマクロなどで扱う場合は、どのバイト数の文字かを仕分けしてから扱う必要があります。
以下、文字コードについては［16進数］で表現します。
IPAmj明朝の場合、1バイト目に ［D8］ を含むかどうか、3～5バイト目が [DB40 DD]を含むかどうかを判断して、姓の実際の文字数、名の実際の文字数を計算して、スペースを挿入して行く必要があります。
VBScriptで2バイトずつ文字コードを確認して本当の文字数を自動で判断
下のVBScriptのコードで青文字の部分は、名前の文字列を受け取って、一文字ずつのデータとコード（16進）を返すサブルーチンです。
呼ぶ側では、氏名の入っているセルのデータの姓名間のスーペースを全角に揃えてから、長さの確認をしてFuncition IPAmj_analyze(氏名の文字列) を呼び出します。
その後、姓と名の文字数に応じて、空白文字を適当に配置してセルに書き出します。
使い方は、メモ帳などを開いて、コードをコピー貼り付けして、[ファイル]-[名前を付けて保存]にて、
『Excel氏名7文字化IPAmj明朝対応.vbs』というファイル名を付けて、文字コードを ANSI にして、[保存]します。
あるいは、ダウンロードのボタンをクリックするとzipファイルがダウンロードできますので、解凍してから Excel氏名7文字化IPAmj明朝対応.vbs のファイルをご利用ください。
名列を含むExcelファイル（ブック)を開いて、名列の一番上のセルをクリックしてアクティブにしてから、 Excel氏名7文字化IPAmj明朝対応.vbs のアイコンをダブルクリックします。
' ダブルクリックすると、今開いているExcelでアクティブなブックのアクティブなシートの、
' 現在アクティブになっているセルから下に向けて氏名についての7文字揃えを行うVBScriptです。
'
' 作者：heijoutomate.info
'
Const xlUp = -4162
Const vbNarrow = 8
'既に開いているエクセルの有無をチェック
On Error Resume Next
Set Excel0 = GetObject(, "Excel.Application")
Set Sheet0 = Excel0.ActiveSheet
If Err.Number <> 0 Then
WScript.Echo ""
WScript.Quit
End If
On Error GoTo 0
'******************************
'Dim moji()
'アクティブなセルの位置を確認
col = Excel0.ActiveCell.Column
i1 = Excel0.ActiveCell.Row
'最終行を確認
iend = Sheet0.Cells(Excel0.Rows.Count, col).End(xlUp).Row
For i = i1 To iend
'半角のスペースを全角に変換
name_x = Replace(Sheet0.Cells(i, col), " ", " ")
moji = IPAmj_analyze(name_x)
'スペースが一つだけ含まれているかどうかと、9文字以内であるかの確認
If InStr(name_x, " ") <> InStrRev(name_x, " ") Or name_x = "" Or UBound(moji) > 9 Then
'変換不能なので、文字色を青にして次の行へ進む
Sheet0.Cells(i, col).Font.Color = vbBlue
Else
'全ての文字をカンマで繋ぐ（含む全角スペース）
simei = Join(moji, ",")
'左右両端のカンマを省く
On Error Resume Next
simei = Mid(simei, 2, Len(simei) - 1)
On Error GoTo 0
'姓名で分割する
sei = Split(simei, ", ,")(0)
On Error Resume Next
mei = Split(simei, ", ,")(1)
If Err.Number <> 0 Then mei = ""
On Error GoTo 0
If mei <> "" Then
'姓、名のそれぞれの長さ
sei_len = Len(sei) - Len(Replace(sei, ",", "")) + 1
mei_len = Len(mei) - Len(Replace(mei, ",", "")) + 1
'姓名の長さ
seimei_wa = sei_len + mei_len
'姓名カンマを全角スペースに置き換える
sei_k = Replace(sei, ",", " ")
mei_k = Replace(mei, ",", " ")
'姓名カンマを詰める
sei = Replace(sei, ",", "")
mei = Replace(mei, ",", "")
'氏名のパターンごとに7文字化
If seimei_wa <= 5 Then
If mei_len = 2 Then mei = mei_k: mei_len = 3
If sei_len = 2 Then sei = sei_k: sei_len = 3
End If
hakudume = 7 - sei_len - mei_len
simei7 = sei & mei
If 7 - seimei_wa >= 0 Then
simei7 = sei & Left(" ", hakudume) & mei
Else
simei7 = Sheet0.Cells(i, col)
Sheet0.Cells(i, col).Font.Color = vbBlue
End If
Sheet0.Cells(i, col) = simei7
End If
End If
Next
MsgBox ("end")
'************************************
If Excel0.Workbooks.Count = 0 Then Excel0.Quit
Set Sheet0 = Nothing
Set Book0 = Nothing
Set Excel0 = Nothing
Set FSO = Nothing
' END ====================================
Function IPAmj_analyze(mojiretu)
Dim moji()
mend = Len(mojiretu)
mset = 0
ReDim Preserve moji(1)
For m = 1 To mend
mojix = Mid(mojiretu, m, 1)
codex = Hex(AscW(mojix))
If Len(codex) >= 4 And (codex >= "DC00" And codex <= "DFFF" Or codex = "DB40") Then
'前につなぐケース
moji(mset) = moji(mset) & mojix
Else
'前につながないケース
mset = mset + 1
ReDim Preserve moji(mset)
moji(mset) = mojix
End If
Next
IPAmj_analyze = moji
End FunctionFollow me!
