マクロ：横並びデータを縦並びに変更

添付のように、横に並んでいるデータを、
縦に並べ変えるマクロを組みたいのですが、
ネットで検索して、組んでみたのですが、
基本的な知識がなくてうまくいきません。

データ量もあり、頻繁に発生する作業なので、
教えて頂けると大変助かります。

よろしくお願い申し上げます。

No.1 ベストアンサー 回答者： rivoisu 回答日時： 2009/09/11 01:36

Option Explicit

Option Base 1
Sub データ正規化()
　　Dim i As Integer
　　Dim j As Integer
　　Dim k As Integer
　　Dim 国 As String
　　Dim 品番 As String
　　Dim カラー As String
　　Dim 転送元 As Worksheet
　　Dim 転送先 As Worksheet
　　Set 転送元 = Worksheets("Sheet1")
　　Set 転送先 = Worksheets("Sheet2")
　　i = 2
　　j = 0
　　While 転送元.Cells(i, 1) <> ""
　　　　国 = 転送元.Cells(i, 1)
　　　　品番 = 転送元.Cells(i, 2)
　　　　カラー = 転送元.Cells(i, 3)
　　　　k = 1
　　　　While Cells(i, k * 2 + 2) <> ""
　　　　　　j = j + 1
　　　　　　転送先.Cells(j, 1) = 国
　　　　　　転送先.Cells(j, 2) = 品番
　　　　　　転送先.Cells(j, 3) = カラー
　　　　　　転送先.Cells(j, 4) = 転送元.Cells(i, k * 2 + 2)
　　　　　　転送先.Cells(j, 5) = 転送元.Cells(i, k * 2 + 3)
　　　　　　k = k + 1
　　　　Wend
　　　　i = i + 1
　　Wend
End Sub

データはSheet1の２行目からA列が空白になるまで
D列以降はサイズと数量の２列1組で複数組
出力はSheet12の１行目から
という仕様で書いてみました

現在酔っ払っているので解説が必要なら後日

この回答へのお礼

ご丁寧にすぐに回答して頂き、大変助かりました。
ありがとうございました。

お礼日時：2009/09/12 01:02

No.2 回答者： Wendy02 回答日時： 2009/09/11 12:22

こんにちは。

標準モジュールに貼り付けてください。
'-------------------------------------------
Sub MacroTest1()
　　Dim rng As Range
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　
　　Set rng = sh1.Range("A1").CurrentRegion
　　Application.ScreenUpdating = False
　　With rng
　　　　.Resize(1, 5).Copy sh2.Cells(1, 1)
　　　　sh2.Cells(1, 5).Value = "数量"
　　　　k = 2 'タイトル行の次の行から
　　　　For i = 2 To .Rows.Count
　　　　　　For j = 4 To .Columns.Count Step 2
　　　　　　　　If .Cells(i, j + 1).Value <> "" Then
　　　　　　　　　　.Cells(i, 1).Resize(, 3).Copy sh2.Cells(k, 1)
　　　　　　　　　　.Cells(i, j).Resize(, 2).Copy sh2.Cells(k, 4)
　　　　　　　　　　k = k + 1
　　　　　　　　End If
　　　　　　Next j
　　　　Next i
　　End With
　　Application.ScreenUpdating = True
　　Set rng = Nothing
　　Set sh1 = Nothing
　　Set sh2 = Nothing
End Sub
　　

'-------------------------------------------
なお、#1さんのコードは間違いではないのですが、お酒のせいでしょうか、以下のように直したほうがよいです。

While Cells(i, k * 2 + 2) <> ""
　　　　↓
While 転送元.Cells(i, k * 2 + 2) <> ""

この回答へのお礼

大変助かりました。
ご丁寧にありがとうございました。

お礼日時：2009/09/12 01:02