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

公開日：2020-11-14　最終更新日：2021-02-22

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

縦横のマトリックス表をデータベース形式の縦に展開する問題です。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

#VBA100本ノック 25本目
画像1のように「売上」シートに横に日付と金額が入力されています。
行数・列数(日数)は増減します。
A列はセル結合されています。
画像2のようにデータベース形式に変換して「売上DB」シートに出力してください。
※「売上DB」は既存で見出しも入っています。

サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_25.xlsm
https://excel-ubara.com/vba100sample/VBA100_25.zip

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

まずは、とにかくVBAを始めたらこれが書けることを目指してほしいVBAから。
最終行・列の取得方法はいろいろありますが、Endプロパティは理解しておきましょう。
そして2重ループです。
ループの中で先頭行・列からの値取得と交点の値取得、これらをしっかり制御できることが必要です。


  
    
      Sub VBA100_25_01()

　　Dim ws1 As Worksheet, ws2 As Worksheet

　　Set ws1 = Worksheets("売上")

　　Set ws2 = Worksheets("売上DB")

　　ws2.Range("A1").CurrentRegion.Offset(1).ClearContents

　　

　　Dim i As Long, j As Long, oRow As Long

　　oRow = 2

　　With ws1

　　　　For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row

　　　　　　For j = 3 To .Cells(1, .Columns.Count).End(xlToLeft).Column

      　　　　　　　　ws2.Cells(oRow, 1).Value = .Cells(i, 1).MergeArea(1).Value '部門

      　　　　　　　　ws2.Cells(oRow, 2).Value = .Cells(i, 2).Value '区分

      　　　　　　　　ws2.Cells(oRow, 3).Value = .Cells(1, j).Value '日付

      　　　　　　　　ws2.Cells(oRow, 4).Value = .Cells(i, j).Value '金額

　　　　　　　　oRow = oRow + 1

　　　　　　Next

　　　　Next

　　End With

End Sub

前記のVBAでは、ループ内で「売上」シートの1行や1列・2列といった定数値が使われています。
これがあると、もしB2から開始の表に変更になった時に修正箇所が何か所も発生してしまい、面倒かつ間違いやすくなってしまいます。
そこで、セル範囲は最初に1度指定するだけで済ませるように変更します。


  
    
      Sub VBA100_25_02()

　　Dim st As Double: st = Timer

　　Dim ws1 As Worksheet, ws2 As Worksheet

　　Set ws1 = Worksheets("売上")

　　Set ws2 = Worksheets("売上DB")

　　ws2.Range("A1").CurrentRegion.Offset(1).ClearContents

　　

　　Dim sRow As Long, eRow As Long

　　Dim sCol As Long, eCol As Long

　　With ws1.Range("A1").CurrentRegion

　　　　sRow = .Item(1).Row

　　　　sCol = .Item(1).Column

　　　　eRow = .Rows.Count + sRow - 1

　　　　eCol = .Columns.Count + sCol - 1

　　End With

　　

　　Dim i As Long, j As Long, oRow As Long

　　oRow = 2

　　For i = sRow + 1 To eRow

　　　　For j = sCol + 2 To eCol

      　　　　　　ws2.Cells(oRow, 1).Value = ws1.Cells(i, sCol).MergeArea(1).Value
      '部門

      　　　　　　ws2.Cells(oRow, 2).Value = ws1.Cells(i, sCol + 1).Value '区分

      　　　　　　ws2.Cells(oRow, 3).Value = ws1.Cells(sRow, j).Value '日付

      　　　　　　ws2.Cells(oRow, 4).Value = ws1.Cells(i, j).Value '金額

　　　　　　oRow = oRow + 1

　　　　Next

　　Next

　　Application.ScreenUpdating = True

　　Debug.Print Timer - st

End Sub

部門なら件数は限られますが、もし件数が多かったら処理時間が気になります。
処理速度を考えるなら、セルへの入出力回数を減らす事になります。
それには、ままずは配列を使えるようになりましょう。
配列を使ったVBAと、セル範囲を一括処理するVBAを記事補足に掲載しました。

補足

出力のみ配列


  
    
      Sub VBA100_25_03()

　　Dim ws1 As Worksheet, ws2 As Worksheet

　　Set ws1 = Worksheets("売上")

　　Set ws2 = Worksheets("売上DB")

　　ws2.Range("A1").CurrentRegion.Offset(1).ClearContents

　　

　　Dim sRow As Long, eRow As Long

　　Dim sCol As Long, eCol As Long

　　With ws1.Range("A1").CurrentRegion

　　　　sRow = .Item(1).Row

　　　　sCol = .Item(1).Column

　　　　eRow = .Rows.Count + sRow - 1

　　　　eCol = .Columns.Count + sCol - 1

　　End With

　　

　　Dim ary()

　　ReDim ary(1 To (eRow - sRow) * (eCol - sCol - 1), 1 To 4)

　　

　　Dim i As Long, j As Long, oRow As Long

　　oRow = 1

　　For i = sRow + 1 To eRow

　　　　For j = sCol + 2 To eCol

      　　　　　　ary(oRow, 1) = ws1.Cells(i, sCol).MergeArea(1).Value '部門

      　　　　　　ary(oRow, 2) = ws1.Cells(i, sCol + 1).Value '区分

      　　　　　　ary(oRow, 3) = ws1.Cells(sRow, j).Value '日付

      　　　　　　ary(oRow, 4) = ws1.Cells(i, j).Value '金額

　　　　　　oRow = oRow + 1

　　　　Next

　　Next

　　

　　ws2.Range("A2").Resize(UBound(ary, 1) - LBound(ary, 1) + 1, _

　　　　　　　　　　　　　 UBound(ary, 2) - LBound(ary, 2) + 1) _

　　　　　　　　　　　　　 = ary

End Sub

入力と出力を配列


  
    
      Sub VBA100_25_04()

　　Dim ws1 As Worksheet, ws2 As Worksheet

　　Set ws1 = Worksheets("売上")

　　Set ws2 = Worksheets("売上DB")

　　ws2.Range("A1").CurrentRegion.Offset(1).ClearContents

　　

　　Dim aryIn, aryOut

　　aryIn = ws1.Range("A1").CurrentRegion.Value

　　ReDim aryOut(1 To (UBound(aryIn, 1) - 1) * (UBound(aryIn, 2) - 2), 1 To 4)

　　

　　Dim i As Long, j As Long, oRow As Long

　　oRow = 1

　　For i = LBound(aryIn, 1) + 1 To UBound(aryIn, 1)

　　　　If aryIn(i, 1) = "" Then aryIn(i, 1) = aryIn(i - 1, 1) '結合セル対策

　　　　For j = LBound(aryIn, 2) + 2 To UBound(aryIn, 2)

      　　　　　　aryOut(oRow, 1) = aryIn(i, 1) '部門

      　　　　　　aryOut(oRow, 2) = aryIn(i, 2) '区分

      　　　　　　aryOut(oRow, 3) = aryIn(1, j) '日付

      　　　　　　aryOut(oRow, 4) = aryIn(i, j) '金額

　　　　　　oRow = oRow + 1

　　　　Next

　　Next

　　

　　ws2.Range("A2").Resize(UBound(aryOut, 1) - LBound(aryOut, 1) + 1, _

　　　　　　　　　　　　　 UBound(aryOut, 2) - LBound(aryOut, 2) + 1) _

　　　　　　　　　　　　　 = aryOut

End Sub

セル範囲を一括処理


  
    
      Sub VBA100_25_05()

　　Dim ws1 As Worksheet, ws2 As Worksheet

　　Set ws1 = Worksheets("売上")

　　Set ws2 = Worksheets("売上DB")

　　ws2.Range("A1").CurrentRegion.Offset(1).ClearContents

　　

　　Dim sRow As Long, eRow As Long

　　Dim sCol As Long, eCol As Long, colCnt As Long

　　With ws1.Range("A1").CurrentRegion

　　　　sRow = .Item(1).Row

　　　　sCol = .Item(1).Column

　　　　eRow = .Rows.Count + sRow - 1

　　　　eCol = .Columns.Count + sCol - 1

　　　　colCnt = eCol - sCol - 1

　　End With

　　

　　Dim wsf: Set wsf = WorksheetFunction

　　Dim ary日付

　　ary日付 = wsf.Transpose(ws1.Cells(sRow, sCol + 2).Resize(, colCnt).Value)

　　

　　Dim i As Long, oRow As Long, rng As Range

　　oRow = 2

　　For i = sRow + 1 To eRow

　　　　'入力1行分を一括で縦に展開

　　　　Set rng = ws2.Cells(oRow, 1).Resize(colCnt)

　　　　rng.Value = ws1.Cells(i, sCol).MergeArea(1).Value '部門

      　　　　rng.Offset(, 1).Value = ws1.Cells(i, sCol + 1) '区分

      　　　　rng.Offset(, 2).Value = ary日付 '日付

      　　　　rng.Offset(, 3).Value = wsf.Transpose(ws1.Cells(i, sCol + 2).Resize(,
      colCnt).Value) '金額

　　　　oRow = oRow + UBound(ary日付, 1)

　　Next

End Sub

処理速度について

・出力のみ配列
・入力と出力を配列
・セル範囲を一括

「出力のみ配列」より「入力と出力を配列」の方が確実に速くなります。
「入力と出力を配列」と「セル範囲を一括処理」では、列数（日数）により変わってきます。
日数が15日くらいまでは前者の方が速いのですが、20日くらいになると後者の方が速くなります。

結果を見れば納得いく感じですが、ではどちらが良いかという事になると難しいところです。

・難易度・・・プログラム作成難易度
・保守性・・・仕様変更等、これは配列の方が融通が効き易いでしょう。
・処理速度・・・列数に依存

このあたりを判断に決めることになると思います。

なお、今回は他シート（開いている他ブックも含む）に計算式がある事を考慮していません。
計算式がある場合は、配列で一括出力する方法以外については自動計算（Application.Calculation）を止めてください。

サイト内関連ページ

第16回．繰り返し処理（For Next）

・For Next ステートメント・For Next 例文・For Next をステップイン実行で目で見て確認しましょう。・１行置きに処理する場合・Exit For ・For～Nextのネスト（入れ子）・最後に一言

第17回．繰り返し処理（Do Loop）

・Do～Loopの構文・条件式・Do Loop 例文・Exit Do ・Do～Loopのネスト（入れ子）・最後に一言

第18回．最終行の取得（End,Rows.Count）

・エクセルVBAにおける最終行取得の必要性・.End(xlDown)：Ctrl+↓ ・.End(xlUp)：Ctrl+↑ ・Endプロパティの方向（↑↓←→）について・セルの行数を取得するRowプロパティ・Cells(Rows.Count, 1).End(xlUp).Rowを日本語に訳す・EndプロパティがRangeオブジェクトを返す・Endプロパティの問題点・最終行に関するサイト内のページ

第85回．結合セルの扱い

・セル結合に関する、メソッド・プロパティ・セル結合のマクロVBA使用例・セル結合時の値消去・指定セル範囲に結合セルが存在するか判定するマクロVBA ・セル結合時のOffsetとResizeの注意点

最終行・最終列の取得方法（End,CurrentRegion,SpecialCells,UsedRange）

・最終行取得の基本：手動ではCtrl + ↑、VBAではCells(1, 1).End(xlDown) ・最終列の取得・特殊な表の場合・CurrentRegion ・SpecialCells(xlCellTypeLastCell) ・UsedRange ・Findメソッド・サイト内関連ページ

同じテーマ「VBA100本ノック」の記事

22本目：FizzBuzz発展問題
 23本目：シート構成の一致確認
 24本目：全角英数のみ半角
25本目：マトリックス表をDB形式に変換
26本目：ファイル一覧作成
 27本目：ハイパーリンクのURL
28本目：シートをブックに分割
 29本目：画像の挿入
 30本目：名札作成（段組み）
31本目：入力規則
 32本目：Excel終了とテキストファイル出力

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.日本の祝日一覧｜Excelリファレンス
3.変数宣言のDimとデータ型｜VBA入門
4.FILTER関数（範囲をフィルター処理）｜エクセル入門
5.RangeとCellsの使い方｜VBA入門
6.繰り返し処理（For Next)｜VBA入門
7.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
8.マクロとは？VBAとは？VBAでできること｜VBA入門
9.セルのクリア（Clear,ClearContents）｜VBA入門
10.メッセージボックス(MsgBox関数)｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
25本目：マトリックス表をDB形式に変換

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。
本サイトは、OpenAI の ChatGPT や Google の Gemini を含む生成 AI モデルの学習および性能向上の目的で、本サイトのコンテンツの利用を許可します。
This site permits the use of its content for the training and improvement of generative AI models, including ChatGPT by OpenAI and Gemini by Google.

VBA練習問題
VBA100本ノック 25本目：マトリックス表をDB形式に変換