[[20080304152534]]　『同じ種類を横並びにする_ソート』（クロ）　ページの最後に飛ぶ

『同じ種類を横並びにする_ソート』（クロ）

 こんにちは。
 前回解決していただいたものの、応用編のようなものでつまづいております。
 　
 前回↓ 
https://www.excel.studio-kazu.jp/cgi-bin/kazuwiki2.cgi?mycmd=read&mypage=[[20080213140737]]

 甘え癖がついてはいけないと自分で考えていたんですが、お手上げになってしまいました。
 お力添えを願えないでしょうか。

 【やりたい事】
 「ID_Group」を元に同一グループ内で日付の古い順にソートして希望図のような形にしたい

 【元の表】Sheet1　※6万件近くあります
 A	B	C	D
 ID_UNIQ	ID_Group	金額	日付
 00_001	10000	262000	20010104
 00_002	10000	260000	19990818
 00_003	10001	197000	20020206
 00_004	10001	215000	19970730
 00_005	10002	268000	19991117
 00_006	10002	275000	20010919
 00_007	10003	72000	20010314
 00_008	10003	72000	20040310
 00_009	10004	105000	19861128
 00_010	10004	125000	19901115
 00_011	10005	110000	19861030
 00_012	10005	78000	19871113
 00_013	10005	110000	19880708

 ↓
 【希望図】Sheet2
 A	B	C	D	E	F	G
 ID_Group	日付	金額				
 10000	19990818	260000	20010104	262000		
 10001	19970730	215000	20020206	197000		
 10002	19991117	268000	20010919	275000		
 10003	20010314	72000	20040310	72000		
 10004	19861128	105000	19901115	125000		
 10005	19861030	110000	19871113	78000	19880708	110000

 【前回弥太郎さんに書いていただいたコードを元に、今回用にいじったもの】

 Private Sub Worksheet_Activate()
     Dim dic As Object, i As Long, tbl, Cnt As Integer, x
     Dim k As Long
     Set dic = CreateObject("scripting.dictionary")
     Application.ScreenUpdating = False
     With Sheets("sheet1")
         tbl = .Range("a1").CurrentRegion.Value
         ReDim x(1 To UBound(tbl, 1), 1 To 10) 'Columns.Count)
         For i = 1 To UBound(tbl, 1)
             If Not dic.exists(tbl(i, 2)) Then
                 j = j + 1
                 n = 1
                 k = 2
                 dic(tbl(i, 2)) = Array(j, n + 1)
                 x(j, n) = tbl(i, 2)
                 x(j, n + 1) = tbl(i, 4)
                 x(j, n + 2) = tbl(i, 3)
             Else
                 x(dic(tbl(i, 2))(0), dic(tbl(i, 2))(1) + k) = tbl(i, 4)
                 x(dic(tbl(i, 2))(0), dic(tbl(i, 2))(1) + k + 1) = tbl(i, 3)
                 dic(tbl(i, 2)) = Array(dic(tbl(i, 2))(0), dic(tbl(i, 2))(1) + 1)
                 Cnt = IIf(dic(tbl(i, 2))(1) > Cnt, dic(tbl(i, 2))(1), Cnt)  'Q01
                 k = k + 1
             End If
         Next i
     End With
     Cells.ClearContents
     Cells(1, 1).Resize(j, Cnt) = x　'Q01_02
     Application.ScreenUpdating = True
  End Sub

 【問題点】
 1・コメントアウト「Q01」部分の意味が理解できず、変数Cntに適正な数値が入らず、
 「Q01_02」部分で範囲がおかしくなる
 2・項目「日付」で古い順にソートしたい（手つかず）

 長々と申し訳ありません。どうぞよろしくお願いします。
－－－－
 一点条件を記し忘れていました。
 項目「日付」が同じ場合、更に「金額」で比較を行い、
 安い方のみを採用するという条件があります。
 同じ「ID_Group」内では、日付は重複しないという事になります。
 (クロ)

 １列ずつ追加するか２列ずつかの違いのようにも見受けられますが。
 並べ替え（日付）先にした方がいいのかな？
 (じゅんじゅん)

 ・前回の方法でID_Group毎に分けてから、
 ・行毎に日付順に並び替えた方が良さそうな感じですね。
 日付はシリアル値ですか？
 バブルソート
http://www.codereading.com/algo_and_ds/algo/bubble_sort.html
 ご参考までに。

 ６万行をワークシートチェンジするたびに行なうとどうなるのかは、検証データがないのと
 時間がないので、これ以上は回答困難です。
 (じゅんじゅん)

 こんなんでうまくいきますかね？
 うまくいったら、Activateイベントに適用して試して下さい。
 (ROUGE)
'----
Sub test()
Dim dic1 As Object, dic2 As Object, tbl, i As Long, ky, x, ws As Worksheet
Set ws = Sheets.Add
Sheets("Sheet1").Range("A1").CurrentRegion.Offset(, 1).Resize(, 3).Copy ws.Range("A1")
Application.CutCopyMode = False
ws.Range("A1").CurrentRegion.Sort key1:=ws.Range("A1"), order1:=xlAscending, _
    key2:=ws.Range("C1"), order2:=xlAscending, header:=xlYes
tbl = ws.Range("A1").CurrentRegion.Resize(, 3).Value
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(tbl, 1)
    ky = tbl(i, 1) & "_" & tbl(i, 3)
    If Not dic1.Exists(ky) Then
        dic1.Add ky, tbl(i, 2)
        If Not dic2.Exists(tbl(i, 1)) Then
            dic2.Add tbl(i, 1), Array(tbl(i, 1), tbl(i, 3), tbl(i, 2))
        Else
            x = dic2(tbl(i, 1))
            ReDim Preserve x(UBound(x) + 2)
            x(UBound(x) - 1) = tbl(i, 3)
            x(UBound(x)) = tbl(i, 2)
            dic2(tbl(i, 1)) = x
        End If
    Else
        If tbl(i, 2) < dic1(ky) Then
            x = dic2(tbl(i, 1))
            x(UBound(x) - 1) = tbl(i, 3)
            x(UBound(x)) = tbl(i, 2)
            dic2(tbl(i, 1)) = x
        End If
    End If
Next
With Sheets("Sheet2")
    .Cells.ClearContents
    .Range("A1:C1").Value = Split("ID_Group 日付 金額")
    i = 1
    For Each ky In dic2.Keys
        i = i + 1
        .Range("A" & i).Resize(, UBound(dic2(ky)) + 1).Value = _
            Application.Transpose(Application.Transpose(dic2(ky)))
    Next
End With
Set dic1 = Nothing
Set dic2 = Nothing
Erase tbl
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End Sub

 じゅんじゅんさん

 ご返答ありがとうございます。
 一気にやるより、グルーピングとソートを分けて行うという事ですね。
 何故か一気にやる事しか考えてませんでした(行き詰ると視野が狭まるのですね･･･)

 日付は文字列です。ご提示のサイトを参考にソートマクロを組んでみようと思います。

 計算時間に関しては既存データに対しての作業ですので、
 ワークシートチェンジである必要はありませんので
 標準モジュールに持って行こうと思います。
 （クロ）

 ↑の書き込み中にROUGEさんからご返答いただきました。
 ありがとうございます！
 早速試してみます。

 じゅんじゅんさんへ。
 今回のデータ量は膨大なので、バブルソートだと相当な時間がかかることが予想されます。
 Excelのソートアルゴリズムであれば、バブルソートと同様の結果が得られますし、高速です。
 また、今回のデータ処理要件であれば、クイックソートでも対応可能だと思います。
 (ROUGE)

 ただいま実行してきました。
 凄いです！6万件が5秒もかからずにさっと終わってしまいました。

 エクセル標準のソートで、複数基準キーを付けられる事すら忘れていました。

 「dictionary」の構造がウォッチだと見えてこなくて
 いまいち理解が進まないのですが、(キーとアイテムの格納状況、引っ張り方など)
 頂いたコードをガン見して、自分でも使えるようにしたいと思います。
 ROUGEさん、じゅんじゅんさんありがとうございました！
 (クロ)

 ROUGEさんへ
 >クイックソートでも対応可能だと思います。
 早速メモメモ。。。
 ありがとうございます。
 (じゅんじゅん)

コメント返信：

[ 一覧(最新更新順) ]

[[20080304152534]] 『同じ種類を横並びにする_ソート』（クロ） ページの最後に飛ぶ

[[20080304152534]]　『同じ種類を横並びにする_ソート』（クロ）　ページの最後に飛ぶ