EXCEL 1行明細への変換マクロ

質問

添付ファイル上部のような行列のある表を
下部のような１行明細に変換したいのですが、
マクロを使えば簡単にできそうな気がするのですが、
簡単なマクロの構文お教えください。

回答No.1

tom04 · ベストアンサー

こんにちは！
一例です。

Sheet1は1行目が項目行で2行目以降にデータがあるとし、Sheet2に表示するします。
Sheet2も2行目以降に表示するとします。

画面左下のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub test() 'この行から
Dim i, j, k As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
k = ws.Cells(Rows.Count, 1).End(xlUp).Row
If k > 1 Then
ws.Rows(2 & ":" & k).ClearContents
End If
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To Cells(i, Columns.Count).End(xlToLeft).Column
With ws.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = Cells(i, 1)
.Offset(, 1) = Cells(1, j)
.Offset(, 2) = Cells(i, j)
End With
Next j
Next i
End Sub 'この行まで

こんな感じではどうでしょうか？m(_ _)m

回答No.4

MarcoRossiItaly

当然マクロでもできますけど、同じ形の表の加工をたくさん繰り返す予定でもなければ、そこまでは必要ないというか。ちょっと数式を書けばすぐできますよ。

先に変形後の表の、「金額」欄以外の部分を作っておきます。次いで、次の式を入力。

C9　=index(B$2:D$4,match(a9,A$2:A$4,),match(b9,B$1:D$1,))

まあデータ量が大して多くないようなら、私なら数式を書くことすらメンドいので、転置行列を貼って終わらせますけどね。つまり質問文の図で言うなら、B2:D4 をコピーし、C9 セルに「形式を選択して貼り付け」するときに、「行列を入れ替える」にチェックして貼り付ける。できた 3 行 3 列の表を 9 行 1 列に変えるため、D9:D11 の範囲を選択し、選択範囲の縁（ふち）をドラッグ・アンド・ドロップで C12:C14 の位置に持ってくる。E9:E11 についても同様に、所定の位置に動かす。といった具合です。

回答No.3

keithin

ＡＬＴ＋Ｆ１１を押す
現れた画面で挿入メニューから標準モジュールを挿入する
現れたシートに下記をコピー貼り付ける

’簡単だけど遅い
sub macro1()
　dim c,cs,r,rs, n

’準備
　cs = 3　’行数
　rs = 3　’列数
　worksheets("Sheet2").select
　cells.clearcontents
　range("A1:C1") = array("商品","店","金額")
　n = 2

’転記
　with worksheets("Sheet1")
　　for r = 2 to rs + 1
　　for c = 2 to cs + 1
　　　cells(n, "A") = .cells(r, "A")
　　　cells(n, "B") = .cells(1, c)
　　　cells(n, "C") = .cells(r, c)
　　　n = n + 1
　　next c
　　next r
　end with
end sub

’少し早い：
sub macro2()
　dim c,cs,r,rs

　cs = 3　’行数
　rs = 3　’列数
　worksheets("Sheet2").select
　cells.clearcontents
　range("A1:C1") = array("商品","店","金額")

　with worksheets("Sheet1")
　　.range("B1").resize(1, cs).copy
　　range("B2").resize(cs * rs, 1).pastespecial transpose:=true
　for r = 2 to rs + 1
　　range("A65536").end(xlup).offset(1).resize(rs, 1) = .cells(r, "A")
　　range("C65536").end(xlup).offset(1).resize(rs, 1) = application.transpose(.cells(r, "B").resize(1, cs))
　next r
　end with
end sub

ファイルメニューから終了してエクセルに戻る
ＡＬＦ＋Ｆ８を押してマクロを実行する。

回答No.2

watabe007

参考に
Sub Test()
　　Dim c As Range
　　Dim v() As Variant
　　Dim i As Long

　　For Each c In Range("A1").CurrentRegion
　　　　If c.Row <> 1 And c.Column <> 1 Then
　　　　　　i = i + 1
　　　　　　ReDim Preserve v(1 To 3, 1 To i)
　　　　　　v(1, i) = Cells(c.Row, 1).Value
　　　　　　v(2, i) = Cells(1, c.Column).Value
　　　　　　v(3, i) = c.Value
　　　　End If
　　Next
　　With Range("A8")
　　　　.Resize(, 3).Value = Array("商品", "店", "金額")
　　　　.Offset(1).Resize(UBound(v, 2), 3).Value = Application.Transpose(v)
　　End With
End Sub