エクセルでデータ並び替え→別シートへ

質問

品名　　蜜柑　林檎　林檎　
　　サイズ　　大　 　小　 　 中　
店名　計
Ａ店　　４　　　２　　　　　　　２
Ｂ店　　６　　　　　　　３　　　３

というテキストがSeet1にあったとしてSeet2へ

店名　品名　サイズ　個数
Ａ店　蜜柑　　大　　　２
Ａ店　林檎　　中 　 　２
Ｂ店　林檎　　小 　 　３
Ｂ店　林檎　　中 　 　３

と並び替えるにはどうしたら良いのでしょうか？

回答No.8

Wendy02

こんばんは。Wendy02です。

マクロを直しました。横に広がっても自動的にデータを取得するようにしました。細かい点も修正しました。（データの上書き,データの場所が違う時,Excelの行数が越えてしまいそうな時のメッセージ,前回よりも、出力が多少速くするようにコードの修正)

フォームのボタンへは、マクロ名にR をつけましたので、再度登録しなおしてください。

'<標準モジュール>
Sub ReArrangingListR()
'改良版
Dim DataAr()
Dim myDescript()
Dim mySize()
Dim OutAr()
Dim DescriptArea As Range
Dim r1 As Range
Dim c As Range
Dim i As Long
Dim j As Long
Dim m As Long

Dim n As Integer
Dim k As Integer
Dim x As Integer
Dim y As Integer
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

'シートの設定の登録
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
With Sh2.Range("A1").CurrentRegion
　If WorksheetFunction.CountA(.Cells) > 1 Then
　If MsgBox("前のデータを削除してよろしいですか？", vbOKCancel) = vbCancel _
　　Then Exit Sub
　　.ClearContents
　End If
End With
Application.ScreenUpdating = False

With Sh1
'項目の部分の設定
Set DescriptArea = .Range("C1", .Range("IV1").End(xlToLeft))
　 If WorksheetFunction.CountA(DescriptArea) = 0 Then
　　 MsgBox "項目名が見つかりません。" & vbCrLf & _
　　 "項目エリアは、" & DescriptArea.Parent.Name & "の" & DescriptArea.Address & "に設定されています。", vbInformation
　　 Exit Sub
　 End If
For Each c In DescriptArea
'品名の取得
　x = x + 1
　ReDim Preserve myDescript(1 To x)
　myDescript(x) = c.Value
Next c
For Each c In DescriptArea.Offset(1)
'サイズの取得
　y = y + 1
　ReDim Preserve mySize(1 To y)
　mySize(y) = c.Value
Next c

'データ範囲(A4～)
Set r1 = .Range("A4", .Range("A65536").End(xlUp))
For i = 1 To r1.Rows.Count
　ReDim Preserve DataAr(DescriptArea.Columns.Count, i)
　For n = 0 To DescriptArea.Columns.Count
　　If n = 0 Then
　　　　DataAr(n, i - 1) = r1.Cells(i, n + 1)
　　Else
　　　　DataAr(n, i - 1) = r1.Cells(i, n + 2)
　　End If
　Next n
Next i
End With

　With Sh2
　'次のシートへのデータの貼り付け
　'タイトル
　.Range("A1:D1").Value = Array("店名", "品名", "サイズ", "個数")
　m = 2 'Sh2の行の初期値
　ReDim OutAr(1 To 4) '出力バッファ
　For j = LBound(DataAr, 2) To UBound(DataAr, 2)
　　For k = 1 To DescriptArea.Columns.Count
　　　If DataAr(k, j) <> Empty Then
　　　　　OutAr(1) = DataAr(0, j)　'店名
　　　　　OutAr(2) = myDescript(k)
　　　　　OutAr(3) = mySize(k)
　　　　　OutAr(4) = DataAr(k, j)
　　　　　.Cells(m, 1).Resize(, 4).Value = OutAr()
　　　　　m = m + 1
　　　　　If m > Sh2.Columns(1).Cells.Count - 1 Then
　　　　　 Application.ScreenUpdating = True
　　　　　 MsgBox "Excel の最大行数を超えようとしていますので、中止します。" & vbCrLf & _
　　　　　 "データを切り分けてください。", vbInformation
　　　　　 Exit Sub
　　　　　End If
　　　End If
　　Next k
　Next j
　End With
　Application.Goto Sh2.Range("A1")
　Application.ScreenUpdating = True
　Set r1 = Nothing: Set Sh1 = Nothing
　Set Sh2 = Nothing: Set DescriptArea = Nothing
　MsgBox "終了!"
End Sub

補足

Wendy02様
遅くなりましたがご回答有難うございます。
すごいです完璧です！

そこで最後にひとつだけ質問です(当初の質問からかなり発展してしまいまして申し訳ありません。)
現在2行目にサイズが有りますが
３行目、４行目とサイズ欄を増やす場合はコードのどの部分を修正及び追加すればよいのでしょうか？