Excelにおいて索引項目ごとにまとめられたノンブルを個々に展開したり，個々に展開されているノンブルを結合するマクロです．

目次

  1. 使い方
    1. 展開マクロ
    2. 結合マクロ
  2. マクロ

使い方

索引の項目名等の入った列と，ノンブルが入った列があるとします．（１行目は見出し行とします．）

ノンブルは以下の規則で展開／結合されます．

結合時（1行に結合） 展開時（複数行に展開）
22 22
22・23 22，23
22〜24 22，23，24
22〜24・28 22，23，24，28
22〜24・28・29 22，23，24，28，29
22〜24・28〜30 22，23，24，28，29，30

展開マクロ

「索引のノンブルを展開」マクロを実行すると，ノンブル以外の列はそのまま複製され，ノンブルが1ページずつに展開されます．

マクロ中のコンフィグでノンブルがどの列に入っているか指定してください．
また，セパレータは「・」と「〜」から変更可能です．

結合マクロ

「索引のノンブルを結合」マクロを実行すると，個別に展開されたノンブルが結合されます．

マクロ中のコンフィグでノンブルがどの列に入っているか指定してください．
また，セパレータは「・」と「〜」から変更可能です．
ノンブルの入った列は索引項目の列より右にしてください．

なお，索引の項目名の入った列と単一のノンブルが入った列の間に何らかの列がある場合，それも考慮して重複を除去し，結合を開始します．
索引作成の際に完全に無視してよい要素は削除するかノンブルより右列へ移動してからマクロを実行してください．

マクロ

マクロのコードは以下の通りです．

Sub 索引のノンブルを展開()

    Application.ScreenUpdating = False

    ' 変数
    Dim i, j As Long
    Dim tmp As Variant
    Dim tmp_0 As Long
    Dim tmp_1 As Long
    Dim sepNakaten As String
    Dim sepTilde As String
    Dim nombreCol As Variant

    ' コンフィグ
    sepNakaten = "・" ' ページ結合記号1
    sepTilde = "〜" ' ページ結合記号2
    nombreCol = "B" ' ノンブルの入った列（列数番号で指定するなら、ダブルクォーテーション抜きで単に2と書く）

    ' 中点展開
    For i = Cells(1, nombreCol).SpecialCells(xlLastCell).Row To 2 Step -1
        tmp = Split(Cells(i, nombreCol), sepNakaten)
        If UBound(tmp) > 0 Then
            For j = UBound(tmp) To 0 Step -1
                Rows(i).Copy
                Rows(i).Insert Shift:=xlDown
                Cells(i + 1, nombreCol) = tmp(j)
            Next j
            Rows(i).Delete
        End If
    Next i

    ' チルダ展開
    For i = Cells(1, nombreCol).SpecialCells(xlLastCell).Row To 2 Step -1
        tmp = Split(Cells(i, nombreCol), sepTilde)
        If UBound(tmp) > 0 Then
            tmp_0 = Val(tmp(0))
            tmp_1 = Val(tmp(1))
            For j = tmp_1 - tmp_0 To 0 Step -1
                Rows(i).Copy
                Rows(i).Insert Shift:=xlDown
                Cells(i + 1, nombreCol) = tmp_0 + j
            Next j
            Rows(i).Delete
        End If
    Next i

    Application.ScreenUpdating = True
    MsgBox "索引のノンブルを展開しました。"

End Sub

Sub 索引のノンブルを結合()

    Application.ScreenUpdating = False

    ' 変数
    Dim i As Long
    Dim maxrow As Long
    Dim sepNakaten As String
    Dim sepTilde As String
    Dim itemCol As Variant
    Dim nombreCol As Variant
    
    ' コンフィグ
    itemCol = "A" ' 索引項目名等の入った最も左の列（列数番号で指定するなら、ダブルクォーテーション抜きで単に1と書く）
    nombreCol = "B" ' ノンブルの入った列（列数番号で指定するなら、ダブルクォーテーション抜きで単に2と書く）
    sepNakaten = "・" ' ページ結合記号1
    sepTilde = "〜" ' ページ結合記号2
    
    ' エラーチェック
    If Columns(itemCol).Column >= Columns(nombreCol).Column Then
        MsgBox "ノンブルは索引項目名より右の列にしてください。"
        End
    End If
    
    ' 重複除去
    With ActiveSheet.Sort.SortFields
        .Clear
        For i = 0 To Columns(nombreCol).Column - Columns(itemCol).Column
            .Add Key:=Columns(Columns(itemCol).Column + i), Order:=xlAscending
        Next i
    End With
    
    With ActiveSheet.Sort
        .SetRange Cells
        .Header = xlYes
        .Apply
    End With
    
    Cells.RemoveDuplicates Columns:=Array(Columns(itemCol).Column, Columns(nombreCol).Column), Header:=xlYes
    
    ' ページ結合の記号を決定
    Dim sepCol As Long
    sepCol = Columns(nombreCol).Column + 1
    Columns(sepCol).Insert

    maxrow = Cells(1, nombreCol).SpecialCells(xlLastCell).Row - 1 ' ノンブルの入った列を使って最終行を決定（ソートをかけたときに1行多くなるので、-1で補正している）
    For i = 2 To maxrow
        If Cells(i, itemCol) = Cells(i + 1, itemCol) Then
            If Cells(i, nombreCol) <> Cells(i + 1, nombreCol) - 1 Then  ' 続きページでないときは中点
                Cells(i, sepCol) = sepNakaten
            ElseIf Cells(i, nombreCol) = Cells(i + 1, nombreCol) - 1 And (Cells(i - 1, itemCol) <> Cells(i, itemCol) Or Cells(i - 1, nombreCol) <> Cells(i, nombreCol) - 1) And (Cells(i + 1, itemCol) <> Cells(i + 2, itemCol) Or Cells(i + 1, nombreCol) <> Cells(i + 2, nombreCol) - 1) Then   '２ページのみのときは中点
                Cells(i, sepCol) = sepNakaten
            Else
                Cells(i, sepCol) = sepTilde
            End If
        End If
    Next i
    
    ' 連続２個目以上の「〜」のある行を削除
    For i = maxrow To 2 Step -1
        If Cells(i, sepCol) = sepTilde And Cells(i - 1, sepCol) = sepTilde Then
            Rows(i).Delete
        End If
    Next i
    
    ' ノンブルを結合
    For i = maxrow To 2 Step -1
        If Cells(i - 1, sepCol) <> "" Then
            Cells(i - 1, nombreCol) = Cells(i - 1, nombreCol) & Cells(i - 1, sepCol) & Cells(i, nombreCol)
            Rows(i).Delete
        End If
    Next i
    
    Columns(sepCol).Delete
    Application.ScreenUpdating = True
    MsgBox "ノンブルを結合しました。"
    
End Sub