| |
▼Sinzin さん：
こんばんは。
以下のデータがシートSheet1のセルＡ１から
設定されているとすると、
> 日付 品名 単価 数量 金額
>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
より他に適当な方法がありそうですけどね！！
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
