行列入れ替えのマクロを教えて下さい。

行と列の入れ替えで縦軸管理に変更するループ処理を行いたいです。
いろいろと調べたのですがマクロの記録で精一杯でした。。。

元データ
店舗・大分類・中分類・小分類・JAN・商品名・規格・売価・1日・2日・3日・・・・31日
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・□ ・□□・□□□・・・・　　
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・□ ・□□・□□□・・・・　　
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・□ ・□□・□□□・・・・　　

処理後
店舗・大分類・中分類・小分類・JAN・商品名・規格・売価・日付・数量
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・1日・□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・1日・□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・1日・□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・1日・□　
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・2日・□□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・2日・□□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・2日・□□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・2日・□□
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・31日・□□□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・31日・□□□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・31日・□□□
○　・○○　・○○○・△　　・△△・△△△・×　・×× ・31日・□□□

行数が元データで40000行と多く、マクロの記録では処理が出来ませんでした。
店舗～売価を日付の移動と同時にコピー添付、最終行までの自動処理を教えていただきたいです。

No.1 ベストアンサー 回答者： tom04 回答日時： 2017/08/15 22:42

こんばんは！

日付列はI列以降になっているのですよね？
元データはSheet1にあり、Sheet2に表示するとします。
尚、Sheet2の1行目項目名は入力済みだという前提です。

一例です。標準モジュールにしてください。

Sub Sample1()
Dim j As Long, lastRow1 As Long, lastRow2 As Long
Dim myStart As Long, myEnd As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
Application.ScreenUpdating = False
lastRow2 = wS.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow2 > 1 Then
Range(wS.Cells(2, "A"), wS.Cells(lastRow2, "J")).ClearContents
End If
With Worksheets("Sheet1")
lastRow1 = .Cells(Rows.Count, "A").End(xlUp).Row
For j = 9 To .Cells(1, Columns.Count).End(xlToLeft).Column
myStart = wS.Cells(Rows.Count, "A").End(xlUp).Row + 1
Range(.Cells(2, "A"), .Cells(lastRow1, "H")).Copy wS.Cells(myStart, "A")
Range(.Cells(2, j), .Cells(lastRow1, j)).Copy wS.Cells(myStart, "J")
myEnd = wS.Cells(Rows.Count, "A").End(xlUp).Row
Range(wS.Cells(myStart, "I"), wS.Cells(myEnd, "I")) = .Cells(1, j)
Next j
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　万一「数量」セルが空白でもそのまま表示されます。m(_ _)m

この回答へのお礼

夜遅く申し訳ありません。

ありがとうございます。
完全一致でした。

空白ありがたいです。他、在庫等ありましたので助かります。

お礼日時：2017/08/15 23:10