More than 5 years have passed since last update.

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

Last updated at 2017-01-31Posted at 2017-01-24

概要

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

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ライセンスに準拠します。
従って、同梱されているファイルを利用した場合に発生したトラブルに関して、以下製作者の責任は問われないものとします。

You get articles that match your needs
You can efficiently read back useful information
You can use dark theme

What you can do with signing up

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

概要