Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


38956 / 76732 ←次へ | 前へ→

【42900】Re:Dictionaryを使用して集計
発言  ichinose  - 06/9/25(月) 6:28 -

引用なし
パスワード
   ▼Sinzin さん:
こんばんは。
以下のデータがシートSheet1のセルA1から
設定されているとすると、

> 日付   品名  単価 数量  金額
>2006/1/15 DPV200 230  123  28,280
>2006/1/20 DPV200 230  36   8,280
>2006/2/10 DZ3000 980  216  211,680
>2006/2/15 DPV200 230  279  64,170
>2006/2/20 DPV200 230  325  74,750
>


Sheet2というシート(Sheet2というシートを初期設定で用意しておいてください)
に以下のような結果を作成します。
>       2006/1    2006/2    ・・・
>    数量計 金額計 数量計 金額計
>DPV200  159  36,560  604  138,920
>DZ3000  ・・ ・・・・ ・・ ・・・・

標準モジュールに
'======================================================================
Option Explicit
Sub test()
  Dim idx As Long
  Dim wk As Variant
  Dim rng As Range
  Dim crng As Range
  Dim dic As Object
  Dim yyyymm As Variant
  Dim num_sum As Variant
  With Worksheets("sheet1")
    Set rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
    End With
  If rng.Row > 1 Then
    yyyymm = mk_unique_array(Application.Transpose(rng), "yyyy/m", 1)
    ReDim num_sum(LBound(yyyymm) To UBound(yyyymm) * 2 + 1)
    For idx = LBound(num_sum) To UBound(num_sum)
     num_sum(idx) = 0
     Next
    Set dic = CreateObject("scripting.dictionary")
    For Each crng In rng
     If Not dic.Exists(crng.Offset(0, 1).Value) Then
       dic.Add crng.Offset(0, 1).Value, num_sum
       End If
     With Application
       idx = .Match(Format(crng.Value, "yyyy/m"), yyyymm, 0) _
            + LBound(yyyymm) - 1
       wk = dic.Item(crng.Offset(0, 1).Value)
       wk(2 * idx) = wk(2 * idx) + crng.Offset(0, 3).Value
       wk(2 * idx + 1) = wk(2 * idx + 1) + crng.Offset(0, 4).Value
       dic.Item(crng.Offset(0, 1).Value) = wk
       End With
     Next crng
    With Worksheets("sheet2")
     For idx = LBound(yyyymm) To UBound(yyyymm)
       With .Range(.Cells(1, 2 * idx + 2), .Cells(1, 2 * idx + 3))
        .NumberFormatLocal = "@"
        .MergeCells = True
        .Value = yyyymm(idx)
        .HorizontalAlignment = xlCenter
        .Offset(1).Resize(, 2).Value = Array("数量", "金額")
        End With
       Next
     .Range("a3", .Cells(UBound(dic.Keys) + 3, "a")).Value = _
         Application.Transpose(dic.Keys)
     .Range("b3", .Cells(UBound(dic.Keys) + 3, UBound(num_sum) + 2)).Value = _
         Application.Transpose(Application.Transpose(dic.Items))
     End With
    Erase wk
    Erase yyyymm
    Erase num_sum
    Set dic = Nothing
    End If
End Sub
'======================================================================
Function mk_unique_array(ByVal InArray As Variant, _
       ByVal frm As String, Optional _
       ByVal do_sort As Long = 0) As Variant
'指定された配列をデータが重複しない配列にする。結果は指定された書式形式にする
' in  InArray 一次元配列
'   frm 書式
'   do_sort ソートの有無 0 無し 1 昇順 2 降順
’               (但し、1,2は、配列が数値の時)
' Out mk_unique_array 重複しないデータの配列
  Dim idx As Long
  Dim tmp As Variant
  Dim dic As Object
  Set dic = CreateObject("scripting.dictionary")
  For Each tmp In InArray
   If do_sort = 1 Then
     tmp = Application.Min(InArray)
   ElseIf do_sort = 2 Then
     tmp = Application.Max(InArray)
     End If
   If Not dic.Exists(Format(tmp, frm)) Then
     dic.Add Format(tmp, frm), ""
     End If
   InArray(Application.Match(tmp, InArray, 0) + _
       LBound(InArray) - 1) = ""
   Next
  mk_unique_array = dic.Keys
  Set dic = Nothing
End Function


testを実行してみてください。

>Dictionaryの使い方を覚えたいと思っていますので、Dictionary
>を使った方法を教えてください。

こういう集計はDictionary
より他に適当な方法がありそうですけどね!!
0 hits

【42892】Dictionaryを使用して集計 Sinzin 06/9/24(日) 18:58 質問
【42900】Re:Dictionaryを使用して集計 ichinose 06/9/25(月) 6:28 発言
【42901】Re:Dictionaryを使用して集計 Sinzin 06/9/25(月) 7:11 お礼
【42902】Re:Dictionaryを使用して集計 ichinose 06/9/25(月) 7:54 発言
【42903】Re:Dictionaryを使用して集計 Sinzin 06/9/25(月) 7:59 お礼
【42904】Re:Dictionaryを使用して集計 Blue 06/9/25(月) 8:49 発言

38956 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free