VBA100本ノック 42本目：データベース形式に変換

公開日：2020-12-08　最終更新日：2021-12-24

VBA100本ノック 42本目：データベース形式に変換

階層構造で入力されているシートをデータベース形式に変換する問題です。

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

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

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

出題

出題ツイートへのリンク

#VBA100本ノック 42本目
画像1のように「階層」シートに階層を表したデータがあります。
これを画像2のように「階層DB」シートにデータベース形式に変換して出力してください。

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

VBA作成タイム

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

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

頂いた回答

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

解説

手動でやるなら、
・A:C列選択、Ctrl+Gのセルの選択で空白選択
・=↑、Ctrl+Enter
・A:C列選択、Ctrl+C、値張り付け
・D列選択、Ctrl+Gのセルの選択で空白選択
・セル削除、行全体
これをVBAで書いてみます。


  
    
      Sub VBA100_42_01()

　　Dim ws階層 As Worksheet, ws階層DB As Worksheet

      　　Set ws階層 = Worksheets("階層")

　　Set ws階層DB = Worksheets("階層DB")

　　

　　ws階層.Cells.Copy Destination:=ws階層DB.Cells

　　

　　On Error Resume Next '念の為のSpecialCells対応

　　With ws階層DB.Range("A1").CurrentRegion

　　　　.Columns("A:C").SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"

　　　　.Columns("A:C").Value = .Columns("A:C").Value

　　　　.Columns("D").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

　　End With

End Sub

1行ずつ処理していく方法も考え方としては良いですし、重要な考え方になります。
A:C列については、空白以外で値が入っていたらその値を退避しておき、詳細行になった時点で出力します。
これは記事補足に掲載しました。

補足

省略されている値を埋める方法として、直前の値を使うという処理はVBAでは時々発生します。
A:C列については、空白以外で値が入っていたらその値を退避しておき、詳細行になった時点で出力します。
件数が多ければ処理時間もかかりますし、まどろっこしく感じてしまいますが、VBA処理の考え方としては是非覚えておきたいものです。


  
    
      Sub VBA100_42_02()

　　Dim ws階層 As Worksheet, ws階層DB As Worksheet

　　Set ws階層 = Worksheets("階層")

　　Set ws階層DB = Worksheets("階層DB")

　　

　　ws階層DB.Range("A1").CurrentRegion.Offset(1).ClearContents

　　

　　Dim i As Long, j As Long, A, B, C

　　j = 2

　　With ws階層

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

　　　　　　If .Cells(i, 1) <> "" Then A = .Cells(i, 1).Value

　　　　　　If .Cells(i, 2) <> "" Then B = .Cells(i, 2).Value

　　　　　　If .Cells(i, 3) <> "" Then C = .Cells(i, 3).Value

　　　　　　If .Cells(i, 4) <> "" Then

　　　　　　　　ws階層DB.Cells(j, 1).Resize(, 4).Value = Array(A, B, C, .Cells(i, 4))

　　　　　　　　j = j + 1

　　　　　　End If

　　　　Next

　　End With

End Sub

上記では、出力は1行まとめていますが、それでも件数が多くなると処理時間がかかりそうです。
入力範囲も一度に配列に取得し、出力も配列で一括で出力するようにすればかなり高速に処理できます。


  
    
      Sub VBA100_42_03()

　　Dim ws階層 As Worksheet, ws階層DB As Worksheet

　　Set ws階層 = Worksheets("階層")

　　Set ws階層DB = Worksheets("階層DB")

　　

　　ws階層DB.Range("A1").CurrentRegion.Offset(1).ClearContents

　　

　　Dim inAry, outAry, tmpAry

　　With ws階層.Range("A1").CurrentRegion

　　　　inAry = Intersect(.Cells, .Offset(1))

　　End With

　　ReDim outAry(LBound(inAry, 1) To UBound(inAry, 1), LBound(inAry, 2) To UBound(inAry, 2))

　　ReDim tmpAry(LBound(inAry, 2) To UBound(inAry, 2))

　　

　　Dim i As Long, j As Long, jj As Long, k As Long

　　k = LBound(inAry, 1)

　　With ws階層

　　　　For i = LBound(inAry, 1) To UBound(inAry, 1)

　　　　　　For j = LBound(inAry, 2) To UBound(inAry, 2)

　　　　　　　　If inAry(i, j) <> "" Then

      　　　　　　　　　　tmpAry(j) = inAry(i, j)

      　　　　　　　　　　'下位項目を消去

　　　　　　　　　　For jj = j + 1 To UBound(inAry, 2)

　　　　　　　　　　　　tmpAry(jj) = ""

　　　　　　　　　　Next

　　　　　　　　End If

　　　　　　Next

　　　　　　If inAry(i, UBound(inAry, 2)) <> "" Then

　　　　　　　　For j = LBound(inAry, 2) To UBound(inAry, 2)

　　　　　　　　　　outAry(k, j) = tmpAry(j)

　　　　　　　　Next

　　　　　　　　k = k + 1

　　　　　　End If

　　　　Next

　　End With

　　

　　ws階層DB.Range("A2").Resize(UBound(outAry, 1) - LBound(outAry, 1) + 1, _

　　　　　　　　　　　　　　UBound(outAry, 2) - LBound(outAry, 2) + 1) = outAry

End Sub

上記VBAでは、小項目が省略されたような場合（出題の表で12行目や17行目が無い場合）、
小項目が空欄になるように、下位項目をクリアする処理を入れています。

サイト内関連ページ

第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プロパティの問題点・最終行に関するサイト内のページ

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

39本目：数値リストの統合（マージ）
40本目：複数ブックの統合
 41本目：暗算練習アプリ
42本目：データベース形式に変換
43本目：CSV出力
 44本目：全テーブル一覧作成
 45本目：テーブルに列追加
 46本目：名前定義に使える文字
 47本目：Window操作
 48本目：配列と数値型
 49本目：条件付き書式の判定

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

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本ノック
42本目：データベース形式に変換

このサイトがお役に立ちましたら「シェア」「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本ノック 42本目：データベース形式に変換