行と列の関係性を一括編集

タイトルが分かり難くてすみません。
教えて頂きたいのは、以下の画像のように変更したいのです。
どのようにするのが最も効率が良いでしょうか？

※実際は商品数やサイズ選択項目が無数にあります。

どうぞ宜しくお願いします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2013/12/21 15:34

こんにちは！

↓の画像で左側がSheet1、右側がSheet2とします。
Sheet2の1行目項目は入力済みだとします。

尚、Sheet1のB列以降（サイズ？）は途中に空白セルはない！という前提です。
標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。

Sub Sample2()
Dim i As Long, startRow As Long, endRow As Long, endCol As Long, wS1 As Worksheet, wS2 As Worksheet
Set wS1 = Worksheets("Sheet1")
Set wS2 = Worksheets("Sheet2")
endRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
If endRow > 1 Then
Range(wS2.Cells(2, "A"), wS2.Cells(endRow, "B")).ClearContents
End If
For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row
endCol = wS1.Cells(i, Columns.Count).End(xlToLeft).Column
If endCol > 1 Then
Range(wS1.Cells(i, 2), wS1.Cells(i, endCol)).Copy
wS2.Activate
ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Transpose:=True
startRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row + 1
endRow = wS2.Cells(Rows.Count, "B").End(xlUp).Row
Range(wS2.Cells(startRow, "A"), wS2.Cells(endRow, "A")) = wS1.Cells(i, "A")
End If
Next i
Application.ScreenUpdating = True
End Sub

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

この回答へのお礼

本当に有難うございます！
理想通りに処理することができました！

これで作業時間が大幅に短縮される上にミスもなくなります。
とても嬉しいです m(_ _)m

お礼日時：2013/12/21 16:21