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

質問

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

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

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

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

回答No.11

Wendy02 · ベストアンサー

noverena　様

こんばんは。

返事が遅くなりました。時間が経つと、この規模のものになると、再び戻るまでにしばらく時間が掛かってしまいます。時間的には、数時間なのですが。
サイズの部分を対話式に切り替えました。良く注意して設定してください。

　　品名
　　サイズ1
　　サイズ2
　　サイズ3
店名　計
－データの始まり－

データの始まりを、サイズの終わりの次の次の行というように考えられていますので、その方式は守ってください。

コードはこの部分です。Sr は、サイズの行数です。
　Set r1 = .Range(.Cells(SizeArea.Row + Sr + 1, 1), .Range("A65536").End(xlUp))
このコードでややこしい部分は、貼り付け部分にあります。ある程度、慣れれば読みきれるかと思います。

ご自身で加工する場合は、なるべくひとかたまりにばらして、位置をキメウチして作ったほうが分りやすいです。以下のような書き方は、掲示板のみに存在する書き方で、実務的ではありません。ロジックそのものは、それほど複雑ではありません。

実際に、お客さんから、こちらの希望している形で入るということは限りませんから、その時の状況にマクロを編集するとなると、細かく分かれていたほうがよいです。また、配列変数を使うべきかどうかは、状況や慣れにもよりますが、ややこしくするだけだと思ったら、セル(Cells(i,j))型の対応で考えたほうが良いかもしれません。

'------------------------------------------------------

'<標準モジュール>
Sub ReArrangingListR2()
　 '再改良版
　 Dim DataAr()
　 Dim myDescript()
　 Dim mySize()
　 Dim DescriptArea As Range
　 Dim SizeArea As Range
　 Dim Sr As Integer 'サイズの行数
　 Dim Sl As Integer 'サイズの列数
　 Dim Sri As Integer 'サイズのカウンタ
　 Dim Slj As Integer　'サイズのカウンタ
　 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 Sh1 As Worksheet
　 Dim Sh2 As Worksheet
　 Dim Srx As Integer '品名変数のルー部
　 Dim LastCol As Integer
　 'シートの設定の登録
　 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

　 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
　　　Application.Goto .Range("A1")
　　　On Error Resume Next
SiZeAreaSet:
　　　Set SizeArea = Application.InputBox("サイズの領域を設定してください" & vbCrLf & "必ず品名の下の行から店名の手前までを選択してください。", "サイズの取得", Type:=8)
　　　If SizeArea Is Nothing Then
　　　　 MsgBox "範囲を取得していません。", vbInformation
　　　　 If MsgBox("再度続けますか?", vbOKCancel) = vbCancel Then
　　　　　　Exit Sub
　　　　 End If
　　　　 GoTo SiZeAreaSet
　　　End If
　　　On Error GoTo 0
　　　Application.ScreenUpdating = False
　　　Sr = SizeArea.Rows.Count
　　　Sl = SizeArea.Columns.Count - 1
　　　ReDim mySize(1 To Sl, 1 To Sr)
　　　'サイズの取得
　　　For Slj = 1 To Sl
　　　　 For Sri = 1 To Sr
　　　　　　mySize(Slj, Sri) = SizeArea.Offset(, 1).Cells(Sri, Slj).Value
　　　　 Next Sri
　　　Next Slj

　　　'データ範囲
　　　Set r1 = .Range(.Cells(SizeArea.Row + Sr + 1, 1), .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:B1").Value = Array("店名", "品名")
　　　.Range("C1").Resize(, Sr).Value = WorksheetFunction.Transpose(SizeArea.Resize(, 1).Value)
　　　.Range("IV1").End(xlToLeft).Offset(, 1).Value = "数量"
　　　LastCol = .Range("IV1").End(xlToLeft).Column
　　　m = 2 'Sh2の行の初期値
　　　For j = LBound(DataAr, 2) To UBound(DataAr, 2)
　　　　 For k = 1 To DescriptArea.Columns.Count
　　　　　　If DataAr(k, j) <> Empty Then
　　　　　　　 .Cells(m, 1).Value = DataAr(0, j)
　　　　　　　 .Cells(m, 2).Value = myDescript(k)
　　　　　　　 For Srx = 1 To Sr
　　　　　　　　 .Cells(m, 3).Cells(, Srx).Value = mySize(k, Srx)
　　　　　　　 Next
　　　　　　　 .Cells(m, LastCol).Value = DataAr(k, j)

　　　　　　　 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

お礼

Wendy様

本当にいろいろ有難うございます！
こんなに親切な方に出会えて感激しています！

この度は本当に有難うございました。