ExcelのVBAで名前の列を選択して一気に５字置換7字置換VBA

一般的な名簿などで、姓名を5文字幅に整えたい場合に使用します。

'================================================================================
' メイン処理：ユーザーが選択した列の姓名を5文字幅に整形する
'================================================================================
Sub 姓名を5文字幅に整形_列選択機能付き()
    '変数を宣言します
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim processRange As Range  '処理対象の全範囲
    Dim targetColumn As Range  'ユーザーが選択した列のセル範囲
    Dim targetColNum As Long   '処理対象の列番号
    Dim cell As Range
    Dim fullName As String
    Dim names() As String
    Dim lastName As String
    Dim firstName As String
    Dim lastNameLen As Long
    Dim firstNameLen As Long
    Dim spacer As String

    '★★★★★ 追加した機能：ここから ★★★★★
    'ダイアログでユーザーに処理対象の列を選択させる
    On Error Resume Next 'ユーザーがキャンセルボタンを押した場合のエラーを無視する
    Set targetColumn = Application.InputBox(Prompt:="処理したい氏名が入力されている列のセルを" & vbCrLf & "どれか一つ選択してください。", Title:="処理列の選択", Type:=8)
    On Error GoTo 0 'エラーハンドリングを通常に戻す

    'キャンセルされたか、または何も選択されなかったかを確認
    If targetColumn Is Nothing Then
        MsgBox "処理がキャンセルされました。", vbInformation
        Exit Sub 'マクロを終了する
    End If
    
    '選択されたセルの列番号を取得する
    targetColNum = targetColumn.Column
    '★★★★★ 追加した機能：ここまで ★★★★★

    '画面の更新を一時的に停止し、処理を高速化します
    Application.ScreenUpdating = False

    '現在アクティブなシートを処理対象に設定します
    Set ws = ActiveSheet

    '★変更点：選択された列でデータが入力されている最終行を取得します
    lastRow = ws.Cells(ws.Rows.Count, targetColNum).End(xlUp).Row

    '処理対象のデータが1行（見出しのみ）以下の場合はメッセージを出して終了
    If lastRow < 2 Then
        MsgBox "選択された列には処理対象のデータがありません。", vbExclamation
        Exit Sub
    End If

    '★変更点：選択された列の2行目から最終行までを処理範囲に設定します
    Set processRange = ws.Range(ws.Cells(2, targetColNum), ws.Cells(lastRow, targetColNum))

    '設定した範囲内の各セルを順番に処理します
    For Each cell In processRange
        'セルの値が文字列で、かつ空でない場合のみ処理を実行します
        If VarType(cell.Value) = vbString And cell.Value <> "" Then
            
            fullName = cell.Value
            
            '【前処理】入力されたスペースを整形します
            '1. 半角スペースを全角スペースに統一します
            fullName = Replace(fullName, " ", "　")
            '2. 連続する全角スペースを1つにまとめます
            Do While InStr(fullName, "　　") > 0
                fullName = Replace(fullName, "　　", "　")
            Loop
            
            '全角スペースで氏名を分割できるか確認します
            If InStr(fullName, "　") > 0 Then
                names = Split(fullName, "　")
                
                '分割後の要素数が2つ（姓と名）の場合のみ処理を続行します
                If UBound(names) = 1 Then
                    lastName = Trim(names(0))
                    firstName = Trim(names(1))
                    
                    '外字（サロゲートペア）対応の文字数カウント関数を使用
                    lastNameLen = CountVisibleCharacters(lastName)
                    firstNameLen = CountVisibleCharacters(firstName)
                    
                    'ルールに基づいて、姓と名の間に入れるスペースを決定します
                    spacer = "" 'まず「その他」のルール（スペース無し）を初期値とします
                    
                    Select Case lastNameLen
                        Case 1 '姓が1文字の場合
                            Select Case firstNameLen
                                Case 1: spacer = "　　　"
                                Case 2: spacer = "　　"
                                Case 3: spacer = "　"
                            End Select
                        Case 2 '姓が2文字の場合
                            Select Case firstNameLen
                                Case 1: spacer = "　　"
                                Case 2: spacer = "　"
                                Case 3: spacer = ""
                            End Select
                        Case 3 '姓が3文字の場合
                            Select Case firstNameLen
                                Case 1: spacer = "　"
                                Case 2: spacer = ""
                            End Select
                        Case 4 '姓が4文字の場合
                            Select Case firstNameLen
                                Case 1: spacer = ""
                            End Select
                    End Select
                    
                    '新しい氏名を組み立ててセルの値を書き換えます
                    cell.Value = lastName & spacer & firstName
                End If
            End If
        End If
    Next cell

    '停止していた画面の更新を再開します
    Application.ScreenUpdating = True

    '処理が完了したことをメッセージで伝えます
    MsgBox ws.Columns(targetColNum).Address(False, False) & " 列の氏名整形が完了しました。"

End Sub

'================================================================================
' 追加した関数：外字（サロゲートペア）を1文字として正しくカウントする
'================================================================================
Private Function CountVisibleCharacters(ByVal text As String) As Long
    '正規表現オブジェクトを使用して文字数をカウントする
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    
    With regex
        .Pattern = "."      '「.」は改行を除く任意の1文字にマッチする
        .Global = True      '文字列全体を検索対象とする
        .MultiLine = True   '複数行をまたいで検索する
    End With
    
    'マッチした数（＝見た目の文字数）を返す
    CountVisibleCharacters = regex.Execute(text).Count
End Function
        

少しゆとりを持たせたい場合や、長い氏名が多い場合に使用します。

'================================================================================
' メイン処理：ユーザーが選択した列の姓名を7文字幅に整形する
'================================================================================
Sub 姓名を7文字幅に整形_7字版()
    Dim ws As Worksheet
    Dim targetColumn As Range
    Dim targetColNum As Long
    Dim cell As Range
    Dim fullName As String, names() As String
    Dim lastName As String, firstName As String
    Dim lastNameLen As Long, firstNameLen As Long
    Dim spacer As String
    Dim lastRow As Long

    ' ユーザーに列を選択させる
    On Error Resume Next
    Set targetColumn = Application.InputBox(Prompt:="7字取りにしたい氏名の列を選択してください。", Title:="7字取り実行", Type:=8)
    On Error GoTo 0

    If targetColumn Is Nothing Then Exit Sub
    targetColNum = targetColumn.Column

    Application.ScreenUpdating = False
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, targetColNum).End(xlUp).Row
    
    If lastRow < 2 Then Exit Sub

    For Each cell In ws.Range(ws.Cells(2, targetColNum), ws.Cells(lastRow, targetColNum))
        If VarType(cell.Value) = vbString And cell.Value <> "" Then
            fullName = Replace(cell.Value, " ", "　") ' 半角を全角へ
            Do While InStr(fullName, "　　") > 0
                fullName = Replace(fullName, "　　", "　")
            Loop

            If InStr(fullName, "　") > 0 Then
                names = Split(fullName, "　")
                If UBound(names) = 1 Then
                    lastName = Trim(names(0))
                    firstName = Trim(names(1))
                    
                    ' 文字数カウント（サロゲートペア対応）
                    lastNameLen = CountVisibleCharacters(lastName)
                    firstNameLen = CountVisibleCharacters(firstName)

                    ' 7字取り用スペーサー判定（姓＋名＋空白＝7）
                    spacer = ""
                    ' 必要な空白数 = 7 - (姓の数 + 名の数)
                    Dim requiredSpaces As Integer
                    requiredSpaces = 7 - (lastNameLen + firstNameLen)
                    
                    If requiredSpaces > 0 Then
                        spacer = String(requiredSpaces, "　")
                    End If

                    cell.Value = lastName & spacer & firstName
                End If
            End If
        End If
    Next cell

    Application.ScreenUpdating = True
    MsgBox "7字取り整形が完了しました。"
End Sub

' 5字版と同様の文字カウント関数を使用
Private Function CountVisibleCharacters(ByVal text As String) As Long
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    With regex
        .Pattern = "."
        .Global = True
    End With
    CountVisibleCharacters = regex.Execute(text).Count
End Function