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

Question

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

めぐみん_ · Accepted Answer

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文だけ一部修正してあとは削除で。

めぐみん_ · Answer

No.9　のコードについて

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

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

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

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

こちらです。

tatsu99 · Answer

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を区別するかその基準がないので、できません。
もし、区別する基準を提示していただければできるかも知れません。

めぐみん_ · Answer

最初変に考えすぎてしまいましたが、ちょっと前に回答した質問とそんなに変わらなかったですね。
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名には気をつけて。

めぐみん_ · Answer

No.6のお礼に対して

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

いえ、使えますよ。

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

tatsu99 · Answer

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

めぐみん_ · Answer

No.4です。

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

tatsu99 · Answer

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

めぐみん_ · Answer

No.2のお礼に対して。

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

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

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

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

kikosi · Answer

二重ループでやればできます。
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 時系列に横一列に並んだデータを 縦に整頓するマクロを教えてください。

No.9です。

No.9 のコードについて

No7です。

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

No.6のお礼に対して

No5です。

No.4です。

念の為、確認ですが

No.2のお礼に対して。

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

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

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

No.9　のコードについて