VBAでセル内の改行ごとに連番を付ける

セル内の改行ごとに連番を付けるには

セルの中で改行をするにはAtl + Enterキーを押します。

ここでは、その改行ごとの先頭に「1. 」から連番を付けるマクロを紹介します。

実行するとこのような感じになります。A列は変換前、B列は変換後です。分かりやすいように幅を変えています。空行の場合は番号を付けず空行のままとしています。

事前設定

以下のVBAコードは事前に正規表現の参照設定をしておく必要があります。

VBAの画面でツールメニュー→参照設定のダイアログを開き、「Microsoft VBScript Regular Expressions 5.5」にチェックを付けることで正規表現のRegExpクラスが利用できるようになります。

セル内の改行ごとに連番を付けるマクロ

選択セル範囲のすべてのセルに対して、改行ごとの連番を設定します。

値が入っていないセルには連番は設定しません。

セル内改行がないセルでも値が設定されていれば「1. 」を先頭に付けます。

Sub セル内改行連番()
    Dim r           As Range        '// 対象セル
    Dim s           As String       '// セル文字列
    Dim v                           '// 改行分割後の配列
    Dim sDiv                        '// 改行分割後の配列の要素
    Dim sConnect    As String       '// 再連結後文字列
    Dim i           As Long         '// ループカウンタ
    Dim reg         As RegExp       '// 正規表現クラス
    Dim vSpace                      '// 空白分割後の配列
    Dim sDivSpace                   '// 空白分割後の配列の要素
    
    '// 選択セル範囲をループ
    For Each r In Selection
        s = r.Value
        
        '// セル内の改行文字で分割
        v = Split(s, vbLf)
        sConnect = ""
        i = 1
        
        '// セル内の改行文字の分割数ループ
        For Each sDiv In v
            '// 半角スペースが含まれる場合
            If (InStr(1, sDiv, " ") > 0) Then
                '// 半角スペースで分割
                vSpace = Split(sDiv, " ")
                Set reg = New RegExp
                reg.Pattern = "[0-9]+\."
                reg.Global = True
                
                '// すでに番号がついている場合の連番振り直し用の処理
                '// 半角スペースで区切られた一番左の要素の数値＋.を除去
                vSpace(0) = reg.Replace(vSpace(0), "")
                sDiv = ""
                
                '// 連番を除去したあとに再度連結
                For Each sDivSpace In vSpace
                    sDiv = sDiv & " " & sDivSpace
                Next
            End If
            
            '// 左右の空白を除去
            sDiv = Trim(sDiv)
            
            '// 初回ループでない場合はセル内改行を付与
            If (i <> 1) Then
                sConnect = sConnect & vbLf
            End If
            
            '// 現在行に文字列が設定されている場合
            If (sDiv <> "") Then
                '// 連番を付与
                sConnect = sConnect & CStr(i) & ". " & sDiv
                '// 連番を１増やす
                i = i + 1
            End If
        Next
        
        '// セル文字列を再設定
        r.Value = sConnect
    Next
End Sub

Sub セル内改行連番()

Dim r As Range '// 対象セル

Dim s As String '// セル文字列

Dim v '// 改行分割後の配列

Dim sDiv '// 改行分割後の配列の要素

Dim sConnect As String '// 再連結後文字列

Dim i As Long '// ループカウンタ

Dim reg As RegExp '// 正規表現クラス

Dim vSpace '// 空白分割後の配列

Dim sDivSpace '// 空白分割後の配列の要素

'// 選択セル範囲をループ

For Each r In Selection

s = r.Value

'// セル内の改行文字で分割

v = Split(s, vbLf)

sConnect = ""

i = 1

'// セル内の改行文字の分割数ループ

For Each sDiv In v

'// 半角スペースが含まれる場合

If (InStr(1, sDiv, " ") > 0) Then

'// 半角スペースで分割

vSpace = Split(sDiv, " ")

Set reg = New RegExp

reg.Pattern = "[0-9]+\."

reg.Global = True

'// すでに番号がついている場合の連番振り直し用の処理

'// 半角スペースで区切られた一番左の要素の数値＋.を除去

vSpace(0) = reg.Replace(vSpace(0), "")

sDiv = ""

'// 連番を除去したあとに再度連結

For Each sDivSpace In vSpace

sDiv = sDiv & " " & sDivSpace

End If

'// 左右の空白を除去

sDiv = Trim(sDiv)

'// 初回ループでない場合はセル内改行を付与

If (i <> 1) Then

sConnect = sConnect & vbLf

End If

'// 現在行に文字列が設定されている場合

If (sDiv <> "") Then

'// 連番を付与

sConnect = sConnect & CStr(i) & ". " & sDiv

'// 連番を１増やす

i = i + 1

End If

'// セル文字列を再設定

r.Value = sConnect

End Sub

コード説明

詳細はコメントの通りなので、概要を説明します。

選択セル範囲を１セルずつ処理するためにSelectionをループします。

ループごとのセルに含まれる改行コードLFでセルの文字列を分割します。LFなのはセル内の改行は改行コードLFによって行われているためです。

LFごとに分割された数だけループします。たとえばLFが1つであれば２回ループすることになります。

あとは改行ごとの文字列に対して、左端に連番を付与していきます。半角スペースの判定を行っているのは、最終的に「連番＋ドット＋半角スペース」を付与するためです。

使い方

連番を付けたいセル範囲を選択して、上のマクロ「セル内改行連番」を実行します。

1. セルに入力します。ここではセル内に改行がある場合、ない場合、セル未入力の場合を用意しています。

2. 連番を付けたいセル範囲を選択します。

3. マクロを実行します。実際には選択状態は維持されたままですが、わかりやすいように選択状態は外しています。

セル内の改行ごとに連番を付けるには

事前設定

セル内の改行ごとに連番を付けるマクロ

コード説明

使い方

関連記事