개요

좋은 타이틀 표현이 생각나지 않았기 때문에 그림으로 표현합니다. 어쩐지 아는 분은 도움을주십시오.


Excel 테이블에서 자주 볼 수 있는 위와 같은 분류 표현을 상호 변환할 수 있는 추가 기능을 만들어 보았습니다. 추출·정렬로 부모의 분류를 모르는 현상을 회피할 수 있습니다.
간단하게 만든 것이므로 제어가 이르지 않을지도 모릅니다. 더 좋은 것이 있으면 알려주세요.
타이틀이나 설명은, 정말로 마음대로 리츠이·리포스트등으로 포착해 주시면 고맙습니다.

사용하는 것

선택하고 오른쪽 클릭 메뉴에서 조작할 수 있습니다.

다운로드

h tp : // l ぃ에서. 이 m/pgm/C㎁s메르게. 지 p
동봉 readme 파일도 확인해 주십시오.

이용방법

Classmerge.xla 파일의 특성을여십시오.

일반 태그의 맨 아래, 보안 열에서 차단 해제를 선택하고 확인을 클릭합니다. (「보안」란 자체가 없으면 다음으로 진행합니다)

UninstallClassmerge.xla도 마찬가지로 1,2를 수행합니다. (애드인 삭제하고 싶을 때 곤란하지 않게 ··)

작업을 수행할 Excel 문서를 엽니다.

Classmerge.xla를 대상 Excel로 끌어서 놓습니다.

매크로 실행 권한 확인 대화 상자가 나타나므로 문제가 없으면 ※1 "매크로 사용"을 수행합니다.

셀을 선택하고 오른쪽 클릭 메뉴에서 분류 제어 메뉴에서 처리할 수 있습니다.

이용 방법(추가 기능 추가)

이용 방법(오시마)의 7.까지 진행한 후, 오른쪽 클릭 메뉴의 「분류 제어 > 추가 기능 제어 > Excel 추가 기능에 추가한다」를 클릭

화면의 지시에 따라 진행하고 Excel을 다시 시작한 후 추가 기능에 추가됩니다.

추가 기능 삭제

UninstallClassmerge.xla 파일의 특성을여십시오.

일반 태그의 맨 아래, 보안 열에서 차단 해제를 선택하고 확인을 클릭합니다. (「보안」란 자체가 없으면 다음으로 진행합니다)

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의 표현을 이용할 수 없어, 면식 받았기 때문이라고 일단 변명해 둡니다·・w

주의점

이용은 자기 책임으로 부탁합니다.

MIT 라이센스를 준수합니다.
따라서, 동봉되어 있는 파일을 이용했을 경우에 발생한 트러블에 관해서, 이하 제작자의 책임은 묻지 않는 것으로 합니다.
(C)RAWSEQ h tp : // l ぃ에서. 이 m
「편집을 유효」 「콘텐츠의 유효화」(매크로의 실행)는 상기 제작자의 소행을 확인 후, 스스로 판단을 부탁합니다.