Qiita Teams that are logged in
You are not logged in to any team

Log in to Qiita Team
Community
OrganizationAdvent CalendarQiitadon (β)
Service
Qiita JobsQiita ZineQiita Blog
Help us understand the problem. What is going on with this article?

Excelの選択範囲の通常表をネスト的な表にするVBAマクロ

More than 3 years have passed since last update.

はじめに

2008年くらいにWindows版Excelで作成したVBAマクロを見つけたので、Mac版Excelでも動くのか試してみたのですが、大抵動く、という結果でした。
せっかくなので、VBAマクロを切り出して残しておこうと思います。

VBAマクロ

概要

以下のようなデータと範囲選択を行なった状態で 表ネスト形式化() を実行すると、、、

実行前イメージ

以下のように、所定の位置に行が挿入され、ネスト的な表に変更されます。

実行後イメージ

図では選択範囲がAとBの2列ですが、それ以上の列でも同じ判定条件で処理を行います。

処理の内容として、単純に処理対象行の上に行を挿入して、選択範囲の1列目を、挿入した行に切り取り・貼り付けしているだけです。行の挿入はワークシート全体に対し行なっているため、Cの列や表の外の0〜5の数字の列も追随します。

また、それなりの罫線を引くVBAマクロもあります。選択範囲の1列目の未入力のセルに横罫線を引かない、といった内容です。(実行結果の図は割愛)

ソース

Option Explicit

'=====================================================================
'共通
'=====================================================================

'---------------------------------------------------------------------
'選択エリア情報格納用
'---------------------------------------------------------------------
Public Type SelectionInfo
    StartRowIndex As Long   '選択エリアの一番上の行インデックス
    StartColIndex As Long   '選択エリアの一番左の列インデックス
    EndRowIndex As Long     '選択エリアの一番下の行インデックス
    EndColIndex As Long     '選択エリアの一番右の列インデックス
    RowCount As Long        '選択エリア内の行数
    ColCount As Long        '選択エリア内の列数
    CurrentRowIndex As Long '現在の行インデックス
    CurrentColIndex As Long '現在の列インデックス
End Type

'---------------------------------------------------------------------
'選択エリア情報格納処理
'---------------------------------------------------------------------
'シートの内容を加工するのに必要となる「選択エリア」の情報を格納して返します。
Public Function GetSelectionInfo() As SelectionInfo

    Dim selInf As SelectionInfo

    With selInf
        .StartRowIndex = Selection.Row
        .StartColIndex = Selection.Column
        .EndRowIndex = Selection.Rows.Count + Selection.Row
        .EndColIndex = Selection.Columns.Count + Selection.Column
        .RowCount = Selection.Rows.Count
        .ColCount = Selection.Columns.Count
        .CurrentRowIndex = ActiveCell.Row
        .CurrentColIndex = ActiveCell.Column
    End With

    GetSelectionInfo = selInf

End Function

'
' 機能一覧
'
'   マクロ名                   概要
'   ------------------------   ------------------------------------------------------
'   表ネスト形式化             連続データをネスト形式に加工します。
'   ネスト表罫線作成           ネストされた表の罫線を引きます。
'   ネスト表罫線作成_細点線版  ネスト表罫線作成の細点線版です。

'=====================================================================
'選択エリアの通常表をネスト表に加工
'=====================================================================
Public Sub 表ネスト形式化()
    NormalTbl2NestTbl
End Sub

Private Sub NormalTbl2NestTbl()
    '選択されている連続データをネスト形式に加工する
    '基データは
    'AAA    BBB    CCC    DDD
    '       EEE    FFF
    '       GGG    HHH    III
    'であること。上記は、
    'AAA
    '       BBB
    '              CCC
    '                     DDD
    '       EEE
    '              FFF
    '(以降省略)
    'となる。
    '実行後、選択エリアだけでなくシート全体の行が追加される

    Dim colIdx As Long
    Dim rowIdx As Long
    Dim selInf As SelectionInfo 'シートの選択領域

    Dim lngAddCnt As Long   '追加行数

    lngAddCnt = 0

    '選択情報取得
    selInf = GetSelectionInfo()

    '最後のセルから逆順に処理を行なう
    'Rowループ
    For rowIdx = (selInf.EndRowIndex - 1) To selInf.StartRowIndex Step -1
        'Colループ
        For colIdx = (selInf.EndColIndex - 1) To (selInf.StartColIndex + 1) Step -1
            'ネスト表形成
            If Cells(rowIdx, colIdx) <> "" Then
                '値がセットされている場合にのみ処理

                If Cells(rowIdx, colIdx - 1) <> "" Then
                    '左のセルに値がセットされている場合にのみ処理

                    '現在の行に1行追加
                    Rows(CStr(rowIdx) & ":" & CStr(rowIdx)).Insert Shift:=xlDown
                    '追加した行に、処理対象のセルよりも左のセルをカット&ペーストする
                    Range(Cells(rowIdx + 1, selInf.StartColIndex), _
                        Cells(rowIdx + 1, colIdx - 1)).Cut _
                        Destination:=Cells(rowIdx, selInf.StartColIndex)
                    '追加した行数を加算
                    lngAddCnt = lngAddCnt + 1
                End If
            End If
        Next
    Next

    '選択エリア修正(加算した行数分拡大する)
    Range(Cells(selInf.StartRowIndex, selInf.StartColIndex), _
          Cells(selInf.EndRowIndex + lngAddCnt - 1, selInf.EndColIndex - 1)).Select

End Sub

'=====================================================================
'選択エリアのネスト表に罫線を引く
'=====================================================================

Public Sub ネスト表罫線作成()
    DrawNestLines (xlThin)
End Sub

Public Sub ネスト表罫線作成_細点線版()
    DrawNestLines (xlHairline)
End Sub

Private Sub DrawNestLines(xlMyPtn As Long)
    'ネストされている表の罫線を引く
    '範囲指定後実行すること

    Dim colIdx As Long
    Dim rowIdx As Long
    Dim selInf As SelectionInfo 'シートの選択領域

    '選択情報取得
    selInf = GetSelectionInfo()

    '大枠作成・中罫線消去
    Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
    Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
    Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
    Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
    Selection.Borders(xlEdgeLeft).Weight = xlMyPtn
    Selection.Borders(xlEdgeTop).Weight = xlMyPtn
    Selection.Borders(xlEdgeBottom).Weight = xlMyPtn
    Selection.Borders(xlEdgeRight).Weight = xlMyPtn

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    'Rowループ
    For rowIdx = selInf.StartRowIndex To selInf.EndRowIndex - 1
        'Colループ
        For colIdx = selInf.StartColIndex To selInf.EndRowIndex - 1
            '罫線引き
            Cells(rowIdx, colIdx).Borders(xlEdgeLeft).LineStyle = xlContinuous
            Cells(rowIdx, colIdx).Borders(xlEdgeLeft).Weight = xlMyPtn
            If Cells(rowIdx, colIdx) <> "" Then
                Range(Cells(rowIdx, colIdx), Cells(rowIdx, selInf.EndColIndex - 1) _
                    ).Borders(xlEdgeTop).LineStyle = xlContinuous
                Range(Cells(rowIdx, colIdx), Cells(rowIdx, selInf.EndColIndex - 1) _
                    ).Borders(xlEdgeTop).Weight = xlMyPtn
                Exit For
            End If
        Next
    Next

End Sub

補足

共通部について

本当は、共通に記述されているPublicな定義は、別のモジュールに定義されていました。Publicのままにしていますが、特別な意味はないので必要に応じてPrivateにして良いです。

所感

「ネスト的な表」という表現で伝わるかどうか微妙です。
当時、機能一覧やタスク一覧を羅列した後に、前述の図のような見出し行を作成して一覧表を作ることが多かったため、このようなVBAマクロを作成していました。
要するに、表をカテゴライズしつつ1つの表にまとめるのに使っていました。

処理対象行の上に行を挿入していますが、これだと書式が想定した内容にならないと思うので、この処理を改善した方が良さそうです。処理対象行の下に行を挿入して、その後処理対象行の上に移動しつつ、1列目の値のみ移動する、のが良いでしょうかね。

Windows版をMacで実行した際の修正点

特にありません。

moroshi
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away