マクロ：情報テーブルの作成

質問

マクロを使って情報テーブルを作成できないかと思っています。
ヘッダの一部が2行になっているテーブルを、1行にすることは可能でしょうか？
（添付画像の上のような表をを下のようしたいと思っています。）

現在、インターネットや手元の資料を参照していますが、
単純に１行のヘッダのテーブル間での転記方法はあるようですが、ヘッダが２行になっているものが見つけられませんでした。そもそもヘッダが２行であったり、結合されているものの転記は難しいのでしょうか。

仕事で莫大な資料を転記しています。
恥ずかしながら、Vlookかコピー＆ペーストをひたすら使用しています。
例えば１つのAという資料を、ｂ/ｃ/ｄという違うフォーマットに転記することもしばしばで、果たしてこの作業に意味はあるのか…と思っています。

まずは情報を一覧で管理できればと思ったのですが、行き詰ってしまいました。
お知恵を拝借させてください。宜しくお願いします。

回答No.5

mitarashi

個々のデータが数値なら、下記の様なコードでデータベースのレコード形式のデータに変換して、ピボットテーブルでお好きな形にまとめるというのは如何でしょうか。そこかしこの集計を表示しない設定にする必要がありますが。
データの集計は「合計」にしておけば、データは各１個だけなので、個々の値が表示される事になります。

元データが1番目のシートにあり、変換後のデータを2番目のシートに入れるものとします。
Sub test()
Dim targetRange As Range, myCell As Range, destRange As Range
Dim fieldNames As Variant

fieldNames = Array("名前", "番号", "種類", "No", "データ")
Set targetRange = Sheets(1).Range("A1").CurrentRegion
Set targetRange = Intersect(targetRange, targetRange.Offset(2, 2))
Set destRange = Sheets(2).Range("A2")
destRange(0).Resize(1, 5).Value = fieldNames
For Each myCell In targetRange.Cells
With destRange
.Value = myCell.EntireRow.Cells(1).Value
.Offset(0, 1).Value = myCell.EntireRow.Cells(2).Value
.Offset(0, 2).Value = myCell.EntireColumn.Cells(2).Value
.Offset(0, 3).Value = myCell.EntireColumn.Cells(1).MergeArea.Cells(1).Value
.Offset(0, 4).Value = myCell.Value
End With
Set destRange = destRange.Offset(1, 0)
Next myCell
End Sub

変換したデータの例
手抜きでC迄しかありませんが、上記コードは汎用的に書いたつもりです。
名前　番号　種類　No　データ
いちご　1-111　A　1　1
いちご　1-111　B　1　1
いちご　1-111　C　1　1
いちご　1-111　A　2　1
いちご　1-111　B　2　1
いちご　1-111　C　2　1

回答No.4

watabe007

>マクロを使って情報テーブルを作成できないかと思っています。
こんにちは、参考に
Sub Test()
　　Dim ws1 As Worksheet, ws2 As Worksheet
　　Dim c As Range, i As Long, r As Long

　　r = 2
　　Set ws1 = Worksheets("Sheet1") '元シート
　　Set ws2 = Worksheets("Sheet2") '転記先シート
　　For Each c In ws1.Range("A3", ws1.Cells(Rows.Count, "A").End(xlUp))
　　　　ws2.Cells(r, 1).Resize(4).Value = c.Value
　　　　ws2.Cells(r, 2).Resize(4).Value = c.Offset(, 1).Value
　　　　ws2.Cells(r, 3).Resize(4).Value = Application.Transpose(ws1.Range("C2:F2").Value)
　　　　For i = 1 To 10
　　　　　　ws2.Cells(r, i + 3).Resize(4).Value = Application.Transpose(c.Offset(, (i - 1) * 4 + 2).Resize(, 4).Value)
　　　　Next
　　　　r = r + 4
　　Next
End Sub

回答No.3

KURUMITO

回答Ｎｏ１，２です。
複雑な式をよく完成されていますね。お示しの式でもよろしいのですが式が長くなりますので次のような式をシート2のＡ2セルには入力して右横方向にドラッグコピーしたのちに下方にもドラッグコピーしてもよいでしょう。
シート1では1行目で必ず1から10までの数字を入力しておくことが重要です。

=IF(ROW(A1)>(COUNTA(Sheet1!$A:$A)-1)*4,"",IF(COLUMN(A1)<=2,INDEX(Sheet1!$A:$B,ROUNDUP(ROW(A1)/4,0)+2,COLUMN(A1)),IF(COLUMN(A1)=3,INDEX(Sheet1!$C$2:$F$2,MOD(ROW(A1)-1,4)+1),IF(AND(COLUMN(A1)>=4,COLUMN(A1)<=13),INDEX(INDEX(Sheet1!$A:$AP,1,MATCH(COLUMN(A1)-3,Sheet1!$1:$1,0)):INDEX(Sheet1!$A:$AP,10000,MATCH(COLUMN(A1)-3,Sheet1!$1:$1,0)+3),ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),""))))

回答No.2

KURUMITO

すみません、シート2のＡ2セルに入力する式を次の式に訂正してください。

=IF(ROW(A1)>(COUNTA(Sheet1!$A:$A)-1)*4,"",IF(COLUMN(A1)<=2,INDEX(Sheet1!$A:$B,ROUNDUP(ROW(A1)/4,0)+2,COLUMN(A1)),IF(COLUMN(A1)=3,INDEX(Sheet1!$C$2:$F$2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=4,INDEX(Sheet1!$C:$F,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=5,INDEX(Sheet1!$G:$J,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),"")))))

補足

有難うございます！

数式で出来たのですね・・・使用したことのない関数もあり、とても自分の力だけでは辿りつけませんでした＾＾；有難うございます！

実は右にはAPまで、更に同じような列が展開していています。
自分なりに教えて頂いた数式を考えてみたのですが・・・以下のようになりました。
大変恐縮ですが、ご面倒ついでに見ていただけると嬉しいです。

=IF(ROW(A1)>(COUNTA(Sheet1!$A:$A)-1)*4,"",IF(COLUMN(A1)<=2,INDEX(Sheet1!$A:$B,ROUNDUP(ROW(A1)/4,0)+2,COLUMN(A1)),IF(COLUMN(A1)=3,INDEX(Sheet1!$C$2:$F$2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=4,INDEX(Sheet1!$C:$F,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=5,INDEX(Sheet1!$G:$J,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=6,INDEX(Sheet1!$K:$N,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=7,INDEX(Sheet1!$O:$R,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=8,INDEX(Sheet1!$S:$V,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=9,INDEX(Sheet1!$W:$Z,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=10,INDEX(Sheet1!$AA:$AD,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=11,INDEX(Sheet1!$AE:$AH,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=12,INDEX(Sheet1!$AI:$AL,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),IF(COLUMN(A1)=13,INDEX(Sheet1!$AM:$AP,ROUNDUP(ROW(A1)/4,0)+2,MOD(ROW(A1)-1,4)+1),"")))))))))))))

回答No.1

KURUMITO

ご質問の意味を勘違いしているかもしれませんが次のようにしてはどうでしょう。
必ずしもマクロで対応する必要もないのではないでしょうか。次のようにすればよいでしょう。
お示しの元の表がシート1に有ってＡ1セルに名前（Ａ1，Ａ2セルが結合セル）、Ｂ1セルが番号（Ｂ2セルと結合で）、Ｃ1セルに1が（Ｆ1セルまでが結合セルで）、Ｇ1セルに2が（Ｊ1セルまでが結合セルで）入力されており、また、Ｃ2セルからＦ2セルまでに、Ｇ2セルからＪ2セルまでのそれぞれＡ，Ｂ，Ｃ，Ｄが入力されており、それらの項目の下方にはそれぞれデータが入力されているとします。
そこでシート2にお求めの表を作成するとします。
Ａ1セルに名前、Ｂ1セルに番号、Ｃ1セルに種類、Ｄ1セルに1、Ｅ1セルに2とそれぞれ項目名を入力します。
Ａ2セルには次の式を入力してＥ2セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(D16)>(COUNTA(Sheet1!$A:$A)-1)*4,"",IF(COLUMN(D16)<=2,INDEX(Sheet1!$A:$B,ROUNDUP(ROW(D16)/4,0)+2,COLUMN(D16)),IF(COLUMN(D16)=3,INDEX(Sheet1!$C$2:$F$2,MOD(ROW(D16)-1,4)+1),IF(COLUMN(D16)=4,INDEX(Sheet1!$C:$F,ROUNDUP(ROW(D16)/4,0)+2,MOD(ROW(D16)-1,4)+1),IF(COLUMN(D16)=5,INDEX(Sheet1!$G:$J,ROUNDUP(ROW(D16)/4,0)+2,MOD(ROW(D16)-1,4)+1),"")))))