シーゴの Excel 研究室

タイトル変更しました （旧称：今日を乗り切るExcel研究所）

トップ > VBA > 【VBA】横持ちデータを縦持ちに変換したい【100本ノック】

【VBA】横持ちデータを縦持ちに変換したい【100本ノック】

VBA

今回もエクセルの神髄様の Twitter 企画「VBA100本ノック」の便乗記事です。 今回のお題はその25本目です。 配列数式を使ってみます。

お題：VBA100本ノック 25本目：マトリック表をDB形式に変換

問題ページ

方針

本題はここ最近いわゆる「横持ち縦持ち変換」と呼ばれているやつですね。

同じような課題をだいぶ昔の記事で扱ったことがあります。

この手の問題は、いかにシート上のセルからセルへの入出力の回数を減らすのかが工夫のしどころになります。

その記事で書いた VBA プログラムでは１行分のデータごとにシート転記していたと思うのですが、今見るともう何をやってるのか分りませんね。 自分で書いておいてなんですが。

今回、正攻法とは違う別のやり方で、ちょっと個人的な興味本位からなる実験的なアイデアを、この機会を借りて試してみたいと思います。

それは配列数式を使う方法です。

実は最近、Excel の新機能であるスピル（SPILL）に関連して配列数式なる機能の存在を知り、ちょっと勉強しているところなので、なんでも配列数式を使ってみたくなるお年頃なのです。

さてアイデアはこうです。

  • 配列数式を介すればリスト用の行データを一括で高速に生成し、一括で高速に転記できるのではないか

ちょっと本題とは離れてしまいますが、これでやってみます。

解答：配列数式を使ってみる

Option Explicit

Sub VBA100_025()
    Const 行見出階層数 = 2
    Const 列見出階層数 = 1
        
    Application.ScreenUpdating = False
        
    Dim yoko As Range
    Set yoko = Worksheets("売上").Range("A1").CurrentRegion
    
    Dim tate As Range
    Set tate = Worksheets("売上DB").Range("A1").CurrentRegion.Offset(1)
    tate.ClearContents
    tate.Columns(3).NumberFormatLocal = "yyyy/m/d" ' シリアル値になってしまうため書式のほうを変更しておく
    
    Call unpivot(yoko, tate, 行見出階層数, 列見出階層数)
    Call fillBlanks(tate.CurrentRegion.Columns(1))
    
    Application.ScreenUpdating = True
End Sub

Sub unpivot(src As Range, dst As Range, rowDim As Integer, colDim As Integer)
    Dim i As Long
        
    Dim refs() As String
    ReDim refs(0 To colDim + rowDim)
    
    Dim vals As Range
    Set vals = Intersect(src, src.Offset(colDim, rowDim))
    
    Dim n As Integer
    n = 0
    For i = 1 To rowDim
        refs(n) = Intersect(src.Columns(i), vals.EntireRow).Address
        n = n + 1
    Next
    For i = 1 To colDim
        refs(n) = Intersect(src.Rows(i), vals.EntireColumn).Address
        n = n + 1
    Next
    refs(n) = vals.Address
    
    ' 各セルをTAB区切りの行データに変換する配列数式
    Dim arrayFormula As String
    arrayFormula = Join(refs, "&""" & vbTab & """&")
    
    ' 配列数式の結果を2次元配列として取得
    Dim tsvs As Variant
    tsvs = WorksheetFunction.Transpose(src.Worksheet.Evaluate(arrayFormula))
    
    Dim recs() As Variant
    ReDim recs(1 To vals.Count)
    
    Dim tsv As Variant
    i = 1
    For Each tsv In tsvs
        recs(i) = tsv ' 1次元配列に伸ばす
        i = i + 1
    Next
    Erase tsvs
    
    With dst.Resize(vals.Count, 1)
        .Value = WorksheetFunction.Transpose(recs)
        .TextToColumns DataType:=xlDelimited, Tab:=True
    End With
End Sub

Private Sub fillBlanks(rng As Range)
    If rng.Cells.Count = 1 Then Exit Sub
    
    Dim blanks As Range
    On Error Resume Next
    Set blanks = rng.SpecialCells(xlCellTypeBlanks)
    On Error GoTo 0
    If blanks Is Nothing Then Exit Sub
    
    Set blanks = Intersect(rng, blanks)
    If blanks Is Nothing Then Exit Sub
    
    Dim col As Range
    For Each col In blanks.Columns
        If col.Row > 1 Then
            col.Value = col.Offset(-1).Rows(1).Value
        End If
    Next
End Sub

　

　

考察

思っていたより面倒でした。

配列数式

上記マクロで数式を組み立てているところがなんかごちゃごちゃしていますが、要は行列見出しとセル値を TAB 区切りで連結するものです。

今、TAB をハイフンに置き換えると最終的に以下のような数式になります。

$A$2:$A$7 & "-" & $B$2:$B$7 & "-" & $C$1:$N$1 & "-" &$C$2:$N$7

ここで、使われているセル参照がすべて範囲アドレスになっているのが分かります。

このよう形式の数式を配列数式いい、数式内容が各セルに対応した2次元配列に展開され、セル個別に計算された結果が保持されます。

配列数式が配列にどう展開されるのかは、以下の記事で少し解説を試みています。

www.shegolab.jp

まあ言葉で説明されるよりデータを見た方が早いでしょう。

配列数式の結果をシート上に展開してみれば以下のようなイメージになります。

f:id:shego:20210223222916p:plain

黒字の部分が配列数式の結果の２次元配列の内容です。

各セルの内容が、その行と列の位置にある見出しを参照しているのが分かります。 （各セル内に値がハイフン区切りで連結されてますが、本来は TAB 区切りを使っています。日付はシリアル値になっています。）

上記 VBA プログラムでは配列数式を、Evaluate メソッドを使ってシートを通さずに直接計算し、２次元配列として取得しています。

あとは縦一列の1次元配列に変換後、出力シート上に一括転記し、「区切り位置」機能を使って TAB 区切り文字列の分割をしています。

処理速度

処理速度的には劇的な改善とまではいきませんでしたが、それでも最速の部類には入ると思います。

配列数式の処理自体は期待通りの速さです。

一番時間がかかっているのはデータをシート上に転記する処理です。

「区切り位置」を使わないベタなロジックも試してみたのですが、むしろその方が遅くなりました。 データ量にもよるかもしれません。

頑張ればもう少し叩けるのかもしれませんが、エクセルの神髄さんの最速のプログラムと比較しても同程度の処理速度なので、これはもう、Excel VBA の技術的な限界に迫っているのではないかとも思えます。

ただし、結合セルからの空白を埋める処理で倍の時間が追加されるので、今回のお題について言えば全体として「負け」を認めざる負えません。

入力側ではなく、出力側で数式配列を用意できれば、データをプログラムに通さずにもっと高速化できる可能性はあります。

でももう気は済んだのでもういいです。 次のお題に行きます。

関連記事

www.shegolab.jp

www.shegolab.jp