概要

良いタイトル表現が思いつかなかったので、絵で表現します。なんとなく分かる方はお役立てくださいませ。

Excel表でよく見られる上記のような分類表現を相互変換できるアドインを作ってみました。抽出・ソートで親の分類が分からなくなる現象を回避することができます。
簡単に作ったものなので制御が至らないかもしれません。もっと良いものがあれば教えてください。
タイトルや説明は、誠に勝手ながらリツイ・リポスト等で捕捉して頂くとありがたいです。

利用していることろ

選択して右クリックメニューで操作できます。

ダウンロード

http://ltside.com/pgm/Classmerge.zip
同梱readmeファイルもご確認くださいませ。

ご利用方法（おためし - アドインを追加せずに利用してみる）

「Classmerge.xla」ファイルのプロパティーを開きます。
全般タグの一番下、「セキュリティ」欄の「ブロックの解除」をチェックし、OKをクリックします。（「セキュリティ」欄自体なければ次に進みます）
UninstallClassmerge.xlaも同様に1,2を行います。（アドイン削除したい時に困ることのないように・・）
処理を実施したい対象のExcelドキュメントを開きます。
Classmerge.xlaを対象のExcelにドラッグアンドドロップします。
マクロの実行許可の確認ダイアログが出現するので、問題無ければ※1、「マクロを有効にする」を行います。
セルを選択し、右クリックメニューに「分類制御」メニューから処理を行うことができます。

ご利用方法（アドイン追加）

ご利用方法（おためし）の7.まで進めた後、右クリックメニューの「分類制御 > アドイン制御 > Excelアドインに追加する」をクリック
画面の指示通り進み、Excelの再起動後、アドインに追加されます。

アドインの削除

「UninstallClassmerge.xla」ファイルのプロパティーを開きます。
全般タグの一番下、「セキュリティ」欄の「ブロックの解除」をチェックし、OKをクリックします。（「セキュリティ」欄自体なければ次に進みます）
Excelドキュメントをすべて閉じます。
UninstallClassmerge.xlaを実行します。
画面の指示通り次に進み、完了します。

ソース

VBマクロなので、結合ルールや動作を改善したい場合は、以下の通りソースから修正を加えてご利用いただけます。（※メニューの名前等を変えたい場合は必ず一旦メニューを削除してから実施してください。）

Classmerge.bas


Const CLASS_CONTROL = "分類制御(&R)"
Const CLASS_MERGE = "分類結合(&R)"
Const UNMERGE_CELL = "結合解除(&U)"
Const CLASS_FILL = "分類フィル(&Y)"
Const REMOVE_MENU = "メニューを削除"
Const INSTALL_ME = "Excelアドインに追加する"
Const UNINSTALL_ME = "Excelアドインから削除する"
Const CLASS_CONTROL_CT = "アドイン制御"
Public isInstalling As Boolean

Function Version()
    If Not IsControl(CLASS_CONTROL) Then
        Version = MsgBox("CLASS_MERGE (C)RAWSEQ" & vbCr & vbLf & "この追加機能を用いて実行した内容は「元に戻す」ことができません。" & vbCr & vbLf & "著作者はこの機能に関わる一切の責任を問われない事をご了承ください。" & vbCr & vbLf & " " & vbCr & vbLf & "※ この画面は単体起動時とアドイン追加後のExcel初回起動時に出現しますが、アドイン追加後の画面を了承していただいた後は出現しません。", vbYesNo)
    End If
End Function

Sub InstallMe()
    If IsAddin("Classmerge") Then
        MsgBox "既に追加されているので、続行できません。"
        Exit Sub
    End If

    If MsgBox("Excelアドインに追加します。よろしいですか？", vbYesNo) = vbNo Then Exit Sub

    RemoveMenuCore 1
    isInstalling = True

    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CopyFile ThisWorkbook.FullName, Application.UserLibraryPath & "Classmerge.xla"
    Set fso = Nothing

    Set myaddin = AddIns.Add(Filename:=Application.UserLibraryPath & "Classmerge.xla")
    myaddin.Installed = True

    MsgBox "Excelアドインを追加しました。次回起動時に有効になります。"
End Sub

Sub UninstallMe()
    MsgBox "Excelを全て終了し、UninstallClassmerge.xlaを実行してください。"
End Sub

Sub RemoveMenu()
    RemoveMenuCore 0
End Sub

Sub RemoveMenuCore(mode)
    If mode = 0 Then
        If IsAddin("Classmerge") Then
            MsgBox "Excelアドインとして追加されているのでアドインから削除してください"
            Exit Sub
        End If
        If MsgBox("分類メニューを削除します。よろしいですか？", vbYesNo) = vbNo Then Exit Sub
    End If
    If IsControl(CLASS_CONTROL) Then
        Application.CommandBars("Cell").Controls(CLASS_CONTROL).Delete
    End If
End Sub

Sub Auto_Open()
    If isInstalling Then Exit Sub
    If Version() = vbNo Then Exit Sub
    AddMenu
End Sub

Sub Auto_Close()
    If Not IsAddin("Classmerge") Then
        If IsControl(CLASS_CONTROL) Then
            Application.CommandBars("Cell").Controls(CLASS_CONTROL).Delete
        End If
    End If
End Sub

Sub AddMenu()

    If Not IsControl(CLASS_CONTROL) Then

        Set contextmenu = Application.CommandBars("Cell").Controls.Add(Type:=msoControlPopup)
        With contextmenu
            .Caption = CLASS_CONTROL
            .BeginGroup = False
            With .Controls.Add()
                .Caption = CLASS_MERGE
                .OnAction = "ClassMerge"
                .FaceId = 798
            End With
            With .Controls.Add()
                .Caption = UNMERGE_CELL
                .OnAction = "UnMerge"
                .FaceId = 800
            End With
            With .Controls.Add()
                .Caption = CLASS_FILL
                .OnAction = "ClassFill"
                .FaceId = 800
            End With
            With .Controls.Add(Type:=msoControlPopup)
                .Caption = CLASS_CONTROL_CT
                .BeginGroup = False

                With .Controls.Add()
                    .Caption = INSTALL_ME
                    .OnAction = "InstallMe"
                End With
                With .Controls.Add()
                    .Caption = UNINSTALL_ME
                    .OnAction = "UninstallMe"
                End With
                With .Controls.Add()
                    .Caption = REMOVE_MENU
                    .OnAction = "RemoveMenu"
                End With
            End With


        End With

    End If

End Sub



Sub ClassMerge()
    Selection.UnMerge
    Call ClassTrim

    Dim r As Range
    Dim first_row As Integer
    Dim first_col As Integer

    first_row = Selection(1).Row
    first_col = Selection(1).Column

    For Each r In Selection
        If r.Value = "" And r.Row > first_row Then
            If r.Column > first_col Then
                If Not r.Offset(, -1).MergeCells Then
                    GoTo continue
                End If
            End If

            Range(r.Offset(-1), r).Merge
        End If
continue:
    Next
End Sub

Sub ClassFill()
    Call UnMerge

    Dim r As Range
    Dim first_row As Integer
    Dim first_col As Integer

    first_row = Selection(1).Row
    first_col = Selection(1).Column

    For Each r In Selection
        If r.Value = "" And r.Row > first_row Then
            If r.Column > first_col Then
                If r.Offset(, -1).Value <> r.Offset(-1, -1).Value Then
                    GoTo continue
                End If
            End If

            r.Value = r.Offset(-1).Value

        End If
continue:
    Next
End Sub

Sub ClassTrim()
    Dim r As Range
    Dim first_row As Integer
    Dim first_col As Integer

    first_row = Selection(1).Row
    first_col = Selection(1).Column

    end_row = Selection(Selection.Count).Row
    end_col = Selection(Selection.Count).Column

    For c_row = end_row To first_row + 1 Step -1
        For c_col = end_col To first_col Step -1

            If c_col > first_col Then
                If Cells(c_row, c_col - 1).Value <> Cells(c_row - 1, c_col - 1).Value Then
                    GoTo continue
                End If
            End If

            If Cells(c_row, c_col).Value = Cells(c_row - 1, c_col).Value Then
                Cells(c_row, c_col).Value = ""
            End If
continue:
        Next
    Next

End Sub

Sub UnMerge()
    Selection.UnMerge
End Sub

Function IsAddin(name As String) As Boolean
    On Error GoTo ex
    IsAddin = False
    If AddIns(name).Installed = True Then
        IsAddin = True
    End If
ex:
End Function

Function IsControl(name As String) As Boolean
    Dim found As Boolean

    For Each c In Application.CommandBars("Cell").Controls
        If c.Caption = name Then
            found = True
        End If
    Next c
    IsControl = found
End Function

ネストが激しいのはVBAだとAndAlsoやOrElseの表現が利用できず、面食らった為と一応言い訳しておきます・・ｗ

注意点

利用は自己責任でお願いします。

MITライセンスに準拠します。
従って、同梱されているファイルを利用した場合に発生したトラブルに関して、以下製作者の責任は問われないものとします。
(C)RAWSEQ http://ltside.com
「編集を有効」「コンテンツの有効化」（マクロの実行）は上記製作者の素行を確認の上、自分自身で判断をお願いします。

【Excel】 一括で同じ分類同士のセルを結合したり、同値で埋める - Classmerge.xla

概要

利用していることろ

ダウンロード

ご利用方法（おためし - アドインを追加せずに利用してみる）

ご利用方法（アドイン追加）

アドインの削除

ソース

注意点

【Excel】一括で同じ分類同士のセルを結合したり、同値で埋める - Classmerge.xla