クラスモジュールについて

下記のコードは型番別で数値1の平均値を型番別でC列に出すコードなのですが
もう一つ条件を増やしてD列の日付を2011年〇〇月〇〇日～2012年〇〇月〇〇日まで
といった感じで指定して平均値をだしたいのです。
重要なポイントなんですが、例えば下記データベースで2011年のすべてを対象とした場合
2011年で計算された平均値を2012年の方にも全く同じ数値になるようにしたいのです。
ぜひ、アドバイスお願いします。長文で申し訳ありません＞＜
正解例
A 　　　B　　　　C 　　　D
型番 数値1 　平均値 　日付
1256 　0.25 　0.24 　　2011/1/1
1256 　0.11 　0.24 　　2011/3/2
1256 　0.36 　0.24 　　2011/5/3
2256 　0.55 　0.62 　　2011/10/4
2256 　0.56 　0.62 　　2011/11/5
2256　 0.75 　0.62 　　2011/12/6
1256 　0.05　 0.24 　　2012/2/1
1256 　0.06 　0.24 　　2012/4/2
1256 　0.07 　0.24 　　2012/6/3
2256　 0.88 　0.62 　　2012/9/4
2256 　0.98 　0.62 　　2012/11/5
2256　 0.74 　0.62 　　2012/12/6
不正解例
A 　　　B　　　　C 　　　D
型番 数値1 　平均値 　日付
1256 　0.25 　0.24 　　2011/1/1
1256 　0.11 　0.24 　　2011/3/2
1256 　0.36 　0.24 　　2011/5/3
2256 　0.55 　0.62 　　2011/10/4
2256 　0.56 　0.62 　　2011/11/5
2256　 0.75 　0.62 　　2011/12/6
1256 　0.05　 　　　　　2012/2/1
1256 　0.06 　　　　 　　2012/4/2
1256 　0.07 　　　　 　　2012/6/3
2256　 0.88 　　　　 　　2012/9/4
2256 　0.98 　　　　 　　2012/11/5
2256　 0.74 　　　　 　　2012/12/6

' 標準モジュール
Public Sub 平均値()
Dim dct As Object
Dim bot As Long
Dim k As Variant
Dim r As Long
Dim itm As Class1

Set dct = CreateObject("Scripting.Dictionary")
bot = Cells(Rows.Count, "A").End(xlUp).Row

For r = 2 To bot
k = CStr(Cells(r, "A").Value)

If dct.Exists(k) Then
Set itm = dct(k)
Else
Set itm = New Class1
dct.Add k, itm
End If

itm.Sum Cells(r, "B").Value
Next

For r = 2 To bot
Cells(r, "C").Value = dct(CStr(Cells(r, "A").Value)).Avg()
Next

End Sub

' クラスモジュール（オブジェクト名「Class1」)
Private total As Double
Private cnt As Long

Public Sub Sum(ByVal v As Double)
total = total + v
cnt = cnt + 1
End Sub

Public Function Avg() As Double
Avg = total / cnt
End Function

No.1 ベストアンサー 回答者： 30246kiku 回答日時： 2013/02/19 10:37

その指定した期間だけ計算して・・・

以下 ★ 部分を追加してみました。

Public Sub 平均値()
　　Dim dct As Object
　　Dim bot As Long
　　Dim k As Variant
　　Dim r As Long
　　Dim itm As Class1
　　Const dtStart As Date = #1/1/2011# ' ★
　　Const dtEnd As Date = #12/31/2011# ' ★

　　Set dct = CreateObject("Scripting.Dictionary")
　　bot = Cells(Rows.Count, "A").End(xlUp).Row

　　For r = 2 To bot
　　　　If (Cells(r, "D") >= dtStart And Cells(r, "D") <= dtEnd) Then ' ★
　　　　　　k = Cells(r, "A").Value
　　　　　　If (dct.Exists(k)) Then
　　　　　　　　Set itm = dct(k)
　　　　　　Else
　　　　　　　　Set itm = New Class1
　　　　　　　　dct.Add k, itm
　　　　　　End If
　　　　　　itm.Sum Cells(r, "B").Value
　　　　End If ' ★
　　Next

　　For r = 2 To bot
　　　　k = Cells(r, "A").Value ' ★
　　　　If (dct.Exists(k)) Then ' ★
　　　　　　Cells(r, "C").Value = dct(k).Avg()
　　　　End If ' ★
　　Next
　　Set dct = Nothing ' ★
End Sub

※ Dictionary のキーの型は何でもよかったと思うので、CStr は省きました。

なお、クラスを使わなくても Dictionary に配列を設定すれば・・・・という例が以下
（上記よりチョピット速くなるかも）

Public Sub 平均値2()
　　Dim dct As Object
　　Dim bot As Long
　　Dim k As Variant, v As Variant
　　Dim r As Long
　　Const dtStart As Date = #1/1/2011#
　　Const dtEnd As Date = #12/31/2011#

　　Set dct = CreateObject("Scripting.Dictionary")
　　bot = Cells(Rows.Count, "A").End(xlUp).Row

　　For r = 2 To bot
　　　　If (Cells(r, "D") >= dtStart And Cells(r, "D") <= dtEnd) Then
　　　　　　k = Cells(r, "A").Value
　　　　　　v = dct(k)
　　　　　　If (Not IsArray(v)) Then ReDim v(1)
　　　　　　v(0) = v(0) + Cells(r, "B").Value
　　　　　　v(1) = v(1) + 1
　　　　　　dct(k) = v
　　　　End If
　　Next

　　For r = 2 To bot
　　　　v = dct(Cells(r, "A").Value)
　　　　If (IsArray(v)) Then Cells(r, "C").Value = v(0) / v(1)
　　Next
　　Set dct = Nothing
End Sub


不都合あれば修正してください。

この回答へのお礼

大変遅くなり、ごめんなさい。
お礼をしてたつもりがちゃんと出来てませんでした。

その節はありがとうございました。

お礼日時：2013/03/27 18:32