エクセル VBA 時系列に横一列に並んだデータを 縦に整頓するマクロを教えてください。

VBAについて質問です。
時系列に並んだ横一列のデータを縦に時系列と種別に分けて
縦に整理したいのですがどなたか、VBAで処理する方法を
ご存知でしょうか？
言葉で説明できないので画像を添付しました。
よろしくお願いします。

質問者からの補足コメント

• 

  画像が小さいので拡大すると
  時間 品名 個数 種類 価格
  10:00 りんご 3 大 中 小 100 50 20
  10:10 梨 5 大 中 中 大 小 80 40 40 80 10
  10:15 イチゴ 4 大 大 小 中 150 150 70 100
  10:30 りんご 2 大 小 100 20
  
  ＜マクロ実施後＞
  
  時間　 品名 　個数 種類 価格
  10:00 りんご 1 大 100
  10:00 りんご 1 中 50
  10:00 りんご 1 小 20
  10:10 梨 　　　１　大 80
  10:10 梨 　　　1　 中 40
  10:10 梨 　　　1　　大　 40
  
  としたいのです。

    補足日時：2017/11/02 04:43

No.11 ベストアンサー 回答者： めぐみん_ 回答日時： 2017/11/02 11:07

No.9です。

他の方の回答（疑問）をみて。
仮に１個当たりの内容を知りたいってだけであれば、

　　　　　　　　　If Not myDic.Exists(st) Then _
　　　　　　　　　　　myDic.Add st, Array(r.Text, r.Offset(, 1).Value, 0, _
　　　　　　　　　　　　　　　　　　　　　r.Range("C1").Offset(, i).Value, r.Range("C1").Offset(, i + n).Value)

　　　　　　　　　　　v = myDic(st)
　　　　　　　　　　　v(2) = v(2) + 1
　　　　　　　　　　　myDic(st) = v

ここの部分を

　　　　　　　　　If Not myDic.Exists(st) Then _
　　　　　　　　　　　myDic.Add st, Array(r.Text, r.Offset(, 1).Value, 1, _
　　　　　　　　　　　　　　　　　　　　　r.Range("C1").Offset(, i).Value, r.Range("C1").Offset(, i + n).Value)

　　　　　　　　　　　'v = myDic(st) 削除
　　　　　　　　　　　'v(2) = v(2) + 1 削除
　　　　　　　　　　　'myDic(st) = v 削除

If文だけ一部修正してあとは削除で。

この回答へのお礼

Dictionary でできるんですね。
私のVBAの知識が足りませんでした。
すらすらと出来たのでとっても感謝です。
ありがとうございました。

お礼日時：2017/11/02 19:24

No.12 回答者： めぐみん_ 回答日時： 2017/11/02 19:18

No.9　のコードについて

転記先の以前のデータを削除で

.Cells.ClearComments '以前のデータを削除します

としましたが、急いでいて１つずれた所を選択してしまいました。
実際には

.Cells.ClearContents '以前のデータを削除します

こちらです。

No.10 回答者： tatsu99 回答日時： 2017/11/02 10:41

No7です。

念のため確認ですが、
元のデータが
10:00 りんご 3 大 大 大 100 100 100
の場合、
並べ替えた結果は
①
10:00 りんご 1 大 100
10:00 りんご 1 大 100
10:00 りんご 1 大 100
ですよね。その前提で作成しています。
②
10:00 りんご 3 大 100
にはなりません。
もし、②にようにしたいということであれば、その旨補足ください。
又、②の場合は、品名、種類、価格が同じなら、同じものという前提でよいのですか。
品名、種類、価格が同じでも、ちがうものがあることはないのでしょうか。
例えば、並べ替えた結果を
③
10:00 りんご 1 大 100・・・・・A
10:00 りんご 2 大 100・・・・・B
のようにしたいということはありますか。
その場合は、どのようにAとBを区別するかその基準がないので、できません。
もし、区別する基準を提示していただければできるかも知れません。

No.9 回答者： めぐみん_ 回答日時： 2017/11/02 10:39

最初変に考えすぎてしまいましたが、ちょっと前に回答した質問とそんなに変わらなかったですね。

Dictionaryいけましたよ。

Sub test()
　Dim myDic As Object
　Dim r As Range
　Dim i As Integer, n As Integer
　Dim st As String
　Dim v

　Set myDic = CreateObject("Scripting.Dictionary")

　With Worksheets("Sheet1") 'Sheet名は適宜修正願います
　　　For Each r In .Range(.Range("A2"), .Cells(Rows.Count, 1).End(xlUp))
　　　　　n = r.Range("C1").Value
　　　　　　　For i = 1 To n
　　　　　　　　　st = Join(Array(r.Text, r.Offset(, 1).Value, r.Range("C1").Offset(, i).Value, _
　　　　　　　　　　　　　　　　　r.Range("C1").Offset(, i + n).Value), "_")

　　　　　　　　　If Not myDic.Exists(st) Then _
　　　　　　　　　　　myDic.Add st, Array(r.Text, r.Offset(, 1).Value, 0, _
　　　　　　　　　　　　　　　　　　　　　r.Range("C1").Offset(, i).Value, r.Range("C1").Offset(, i + n).Value)

　　　　　　　　　　　v = myDic(st)
　　　　　　　　　　　v(2) = v(2) + 1
　　　　　　　　　　　myDic(st) = v
　　　　　　　Next
　　　Next
　End With

　With Worksheets("Sheet2") 'Sheet名は適宜修正願います
　　　.Cells.ClearComments '以前のデータを削除します
　　　.Range("A1:E1").Value = Array("時間", "品名", "個数", "種類", "価格")
　　　.Range("A2").Resize(myDic.Count, 5).Value = _
　　　Application.Transpose(Application.Transpose(myDic.Items))
　End With

　Set myDic = Nothing

End Sub

あとはコピーを取ったブックでテストしてみて下さい。
Sheet名には気をつけて。

No.8 回答者： めぐみん_ 回答日時： 2017/11/02 10:08

No.6のお礼に対して

＞Dictionary Objectは使えませんでした。

いえ、使えますよ。

ただ回答が付いたようなので、私の回答必要ないかな？

No.7 回答者： tatsu99 回答日時： 2017/11/02 09:28

No5です。

以下のマクロを標準モジュールに登録してください。
元のシートのシート名は、"Sheet1"
並べ替え後のシートのシート名は、"Sheet2"にしてあります。
もしシート名が異なるなら
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
の箇所をあなたの環境のシート名に合わせてください。
並べ替え後のシートのセルの日付等の書式設定はあなたが適切に行ってください。（一度行えば、ずっとそれが保持されます）
並べ替え後のシートの1行目の見出し行は、あなたが作成しておいてください。
------------------------------------------------------
Option Explicit
Public Sub 並べ替え()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim row1 As Long
Dim row2 As Long
Dim i As Long
Dim kosu As Long
Dim cola As Long
Dim colb As Long
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
maxrow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row '最大行取得
maxrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row '最大行取得
If maxrow2 > 1 Then
sh2.Range("A2:" & "E" & maxrow2).Value = ""
End If
row2 = 2
'2行～最終行まで繰り返す
For row1 = 2 To maxrow1
kosu = sh1.Cells(row1, "C").Value
'個数分繰り返す
For i = 1 To kosu
sh2.Cells(row2, "A").Value = sh1.Cells(row1, "A").Value '時間
sh2.Cells(row2, "B").Value = sh1.Cells(row1, "B").Value '品名
sh2.Cells(row2, "C").Value = 1 '個数
cola = 3 + i
sh2.Cells(row2, "D").Value = sh1.Cells(row1, cola).Value '種類
colb = 3 + kosu + i
sh2.Cells(row2, "E").Value = sh1.Cells(row1, colb).Value '価格
row2 = row2 + 1
Next
Next
MsgBox ("完了")
End Sub

この回答へのお礼

ありがとうございます。　For Next の構文だけで出来るんですね。
参考になりした。
とても良かったのですが、実際のデータ数がかなりあり、試したのですが
かなり時間が掛かってしまいました。

お礼日時：2017/11/02 19:22

No.6 回答者： めぐみん_ 回答日時： 2017/11/02 08:52

No.4です。

すなわち【時間－品名－種類－価格】の組み合わせで【個数】のカウントが取れれば宜しいのですよね？
ならDictionaryオブジェクト１個使ってやればいけそうですが、検証には時間かかるかも知れませんので、
他に回答が付いたら締め切って頂いても構いません。

この回答へのお礼

色々ありがとうございます。
残念ながら、品名、種類が同じでも価格が全て違うので、
一つ一つを時系列に列挙する必要があり、Dictionary Objectは
使えませんでした。

お礼日時：2017/11/02 09:00

No.5 回答者： tatsu99 回答日時： 2017/11/02 08:10

念の為、確認ですが

１）元のシートの個数がn個の場合、その次の列に、n個の種類が並び、更にそのあとに、n個の価格が並ぶ。
２）並び替え後のシートの個数は、常に１個である。（個数が２個又は３個等になることはない）
という前提で良いでしょうか。

この回答へのお礼

回答ありがとうございます。
１）その前提で考えて頂いて結構です。
２）常に1個に対する種類と価格があります。
よろしくお願いします。

お礼日時：2017/11/02 08:13

No.4 回答者： めぐみん_ 回答日時： 2017/11/02 08:00

No.2のお礼に対して。

＞種類の数は大中小だけでなく、様々な種類、があります。

お聞きしたかったのは、それぞれの【種類】に対して【個数】をカウントする必要の有無と、
【種類】が同じでも【価格】が違う場合があるのかどうかですね。

別回答で二重ループの話が出てますが、それにつきましては賛同しますけど、
No.1の回答に書いたように【梨　大】が８０と４０になっているのか？
質問の写真や補足からは【梨　大】は８０しかなく、【個数】は【２】になるはずなのにと言う点です。

考え方としてはNo.3さんと似た感じになりそうですが、C列の使い方とカウントの取り方が違う位ですかね。
でも【種類】が多いってなると私には大変かな？（VB.NETなら機能が色々あって楽なんですけど）

この回答へのお礼

お付き合い頂きありがとうございます。
仰るとおり、種類に対して個数をカウントする必要があります。
種類が同じでも価格が違う場合があり、一つ一つの価格を把握する為、
例えば3個売れた【梨】が一つ一つの価格を横に列記したいと考えております。

お礼日時：2017/11/02 08:10

No.3 回答者： kikosi 回答日時： 2017/11/02 06:27

二重ループでやればできます。

1.行ごとのループ(loop変数をnLineとします)
2.各行の商品のループ(ループ変数をnCellとします)
ループ回数は、C列の数を使います。(nCntにセットしたとします)
shtResult.cells(nWrtLine,1)=shtData.cells(nLine,1).Value
shtResult.cells(nWrtLine,2)=shtData.cells(nLine,2).Value
shtResult.cells(nWrtLine,3)=shtData.cells(nLine,3+nCell).Value
shtResult.cells(nWrtLine,4)=shtData.cells(nLine,3+nCnt+nCell).Value
nWrtLine = nWrtLine+1




そして

この回答へのお礼

回答ありがとうございます。
凄く大きなヒントをもらったような。。。！
やってるんですができませんね。。
もう少し、VBAを勉強します。
ありがとうございます！

お礼日時：2017/11/02 07:51