Excel
ExcelVBA
エクセル
ピボットテーブル
Excel VBADay 16

行と列および交点で構成されるデータ表

入力のしやすさ?その後のデータ加工のしやすさ?

次の図のような表が業務をしていると身近にたくさんあると思います。いわゆる行項目と列項目とその交点にて構成されるデータ表です。入力する際はなんとなくわかりやすくてよいと思いますが、データを扱う側の視点で考えるとデータ加工がとにかくしづらい。そこで、この画像の黄色のデータとその行と列の項目が一瞬でレコード型データへと加工できたら便利だと思いませんか。恐らく今のExcel標準機能ではできないと思っていますので私はVBAで実現して使っています。行や列のやっかいな結合セルに関する処理もそれなりに実装しています。なお、処理速度についてはまだまだ課題ありといったところでまったくもって完璧ではありませんが、今回は何かのアイディアの参考になればと思いご紹介します。(エクセル標準機能でもし実現できるならその方法教えてほしいところ)
data1.png

全自動はまだできていませんが

まだ全自動までは出来ませんが私はこうしています。※まったくきれいなコードではないです、すみません。

Sub KeitaKushimaMatrix()       
    If Selection.Areas.Count <> 2 Then
        MsgBox "マトリクスを構成する計2エリアを縦→横の" & vbCrLf & "順で選択し直し、再度お試しください。", , "ヒント"
        Exit Sub
    End If
    '---------------------------
    '選択範囲1
    a1T = Selection.Areas(1).Item(1).Row
    a1R = Selection.Areas(1).Item(Selection.Areas(1).Count).Column
    a1B = Selection.Areas(1).Item(Selection.Areas(1).Count).Row
    a1L = Selection.Areas(1).Item(1).Column
    a1W = Selection.Areas(1).Columns.Count
    '---------------------------
    '選択範囲2
    a2L = Selection.Areas(2).Item(1).Column
    a2B = Selection.Areas(2).Item(Selection.Areas(2).Count).Row
    a2T = Selection.Areas(2).Item(1).Row
    a2R = Selection.Areas(2).Item(Selection.Areas(2).Count).Column
    a2H = Selection.Areas(2).Rows.Count
    '---------------------------
    If a1T <= a2B Or a1R >= a2L Then
        MsgBox "マトリクスを構成する要素を正しい位置で選択してください。", vbExclamation, "ヒント"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    'シートの追加
    actsht = ActiveSheet.Name
    shtname = "整理完了データ_" & Right(Year(Date), 2) & Format(Month(Date), "00") & Format(Day(Date), "00") & Format(Now(), "hhmmss")
    Worksheets.Add(Before:=Worksheets(1)) _
              .Name = shtname
    Worksheets(actsht).Select   
    n = 1
    For Each c In Range(Cells(a1T, a2L), Cells(a1B, a2R))
        statusNow = Round(n * 100 / ((a2R - a2L + 1) * (a1B - a1T + 1)), 0)
        statusrest = 100 - Now
        Application.StatusBar = "少々お待ちください(数秒で完了します)>" & statusNow & "%"
        If c <> "" Then
            '行データの書出し
            For i = 1 To a1W
                If Cells(c.Row, a1L + i - 1).Column = Cells(c.Row, a1L + i - 1).MergeArea.Item(1).Column Then
                    Worksheets(shtname).Cells(n, i) = Cells(c.Row, a1L + i - 1).MergeArea.Item(1)
                End If
            Next i
            '列データの書出し
            For i = 1 To a2H
                If Cells(a2T + i - 1, c.Column).Row = Cells(a2T + i - 1, c.Column).MergeArea.Item(1).Row Then
                    Worksheets(shtname).Cells(n, a1W + i) = Cells(a2T + i - 1, c.Column).MergeArea.Item(1)
                End If
            Next i
            '交点の書出し
            Worksheets(shtname).Cells(n, a1W + a2H + 1) = c
            n = n + 1
        End If
    Next c
    Application.StatusBar = "処理が完了しました>" & "100%"
    Application.DisplayAlerts = False
    If n = 1 Then
        Worksheets(actsht).Select
        Worksheets(shtname).Delete
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Unload UserForm_Wait
        MsgBox "選択エリアの交点にデータが1つもありません。" & vbCrLf & "処理を中止しました。", vbInformation, "お知らせ"
        Application.StatusBar = False
    Else
        Worksheets(shtname).Select
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Unload UserForm_Wait
        MsgBox "データ整理が完了しました", vbInformation, "お知らせ"
        Application.StatusBar = False
    End If
End Sub

このマクロの使い方ですが、下記画像のように使います。Ctrlを押しながら縦方向をドラック、そのまま次に横方向をドラック。
2つのエリアが選択された状態でマクロを実行するだけで処理は完了します。
data1.png
こんなデータが得られます。縦並びに整形されたきれいなデータです。
data1.png
お時間ある方はちょっと上記コードをお試しください。このコードの有用性に気がつくまでさほど時間はかからないいと思います。

プログラムのポイント

ポイントは特にないです。このアイディアをここで把握いただいた方はもっときれいなプログラムを書いてみてください。しいてポイントをあげるとすれば

Cells(~, ~).MergeArea.Item(1)

の部分です。結合セルにおける表示項目名を取得できますので、For文で巡回中のセルが結合セルのうち左上に属するセルではない場合、これを使うとうまくいきます。具体的には、例えばA1:C3結合のB2巡回中に通常B2には何もありませんのでそのままB2を処理として使うと不都合生じることがありますがRange("B2").MergeArea.Item(1)はB2が所属する結合セルうち左上の1つつまり今回の場合はA1を取ってくれるのでうまいくいくようなイメージです。

このプログラムをどのように改善したいか

上で手順として書いた①と②をなくして人が目で見て判断したであろうその表をロジックとして自動判定して①②とその交点エリアの情報を全自動で加工してくれる、本当に何も考えずにボタンを押すだけでよいデータ加工機能を作ってみたいと思う今日この頃です。多くの説明を必要とせずユーザはこの表の意図を行や列項目から理解して入力が開始できるように、何がタイトルで何が入力事項であるかは一定のロジックで自動判定が必ずできるはずと信じて今後も考えて行きたいと思います。