VBA練習問題
VBA100本ノック 42本目:データベース形式に変換

VBAを100本の練習問題で鍛えます
最終更新日:2021-01-13

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


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


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

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ よりダウンロードできます。
マクロVBA情報を中心に、エクセル関数・基本操作までサンプルとともに解説。初心者向けの基本から上級者向けの高度な内容までVBAサンプルコードを掲載解説しています。


出題

出題ツイートへのリンク

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

マクロ VBA 100本ノック

マクロ VBA 100本ノック


頂いた回答

解説

手動でやるなら、
・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("階層DB")
  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)
VBAのForNextは、同じ処理を繰り返し行うためのVBA構文です。繰り返し処理はループ処理とも呼ばれます。マクロでのループ処理の記述は何通りかありますが、まず最初に覚えるべきものが、今回説明するForNextです。
第17回.繰り返し処理(Do Loop)
繰り返し処理として、前回はFor~Nextをやりました、今回はDo~Loopです。For~Nextに比べると使用頻度は落ちますが、必ず覚える必要があるものです。For~Nextは、繰り返す回数をあらかじめ指定するものでしたが、Do~Loopは、繰り返す回数ではなく、繰り返す条件を指定するものです。
第18回.最終行の取得(End,Rows.Count)
Excelワークシートにおける表の最終行の取得は、VBAの必須技術になります、エクセルVBAにおける最終行取得の必要性 エクセルは表計算ソフトです、つまり縦横の表を扱います、データは横に項目があり、縦に項目に対するデータが入っている事が一般的です。しかし、そのデータ行数は決まった行数ではない事が普通です。




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

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


新着記事NEW ・・・新着記事一覧を見る

VBA100本ノック 68本目:全テキストボックスの転記|VBA練習問題(1月16日)
VBA100本ノック 67本目:ComboBoxとListBox|VBA練習問題(1月15日)
VBA100本ノック 66本目:全サブフォルダからファイルを探す|VBA練習問題(1月13日)
VBA100本ノック 65本目:固定長テキスト出力|VBA練習問題(1月12日)
VBA100本ノック 64本目:リンクされた図(カメラ機能)|VBA練習問題(1月11日)
VBA100本ノック 63本目:複数シートの連結|VBA練習問題(1月9日)
VBA100本ノック 62本目:独自のZLOOKUP関数を作成|VBA練習問題(1月8日)
VBA100本ノック 61本目:「ふりがな」の取得と設定|VBA練習問題(1月6日)
VBA100本ノック 60本目:「株式会社」の表記ゆれ置換|VBA練習問題(1月5日)
VBA100本ノック 59本目:12ヶ月分のシートを四半期で分割|VBA練習問題(1月4日)


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

1.最終行の取得(End,Rows.Count)|VBA入門
2.RangeとCellsの使い方|VBA入門
3.変数宣言のDimとデータ型|VBA入門
4.マクロって何?VBAって何?|VBA入門
5.セルのコピー&値の貼り付け(PasteSpecial)|VBA入門
6.繰り返し処理(For Next)|VBA入門
7.Range以外の指定方法(Cells,Rows,Columns)|VBA入門
8.セルに文字を入れるとは(Range,Value)|VBA入門
9.とにかく書いてみよう(Sub,End Sub)|VBA入門
10.繰り返し処理(Do Loop)|VBA入門




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


記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。



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