Excel2002VBAを使っての集計方法（集計条件が多い場合）

質問

Excel2002を使用しています。
“コード”を　Sheet1のセルA1　として
下記の様なリストがあります。

コード　対象区分　件数
201　　　　　1　　　　1
102　　　　　5　　　　5
503　　　　　4　　　　2
201　　　　　2　　　　2
108　　　　　2　　　　3
108　　　　　8　　　　4
324　　　　　9　　　　5

このリスト使って件数を集計するのですが、
集計条件が下記の条件です。
　集計条件
　　コード　201　503
　　対象区分　1　4　7　8　9

この条件を満たす件数の合計3をExcelVBAを使って
Sheet2のセルA1に入力したいのですが、効率の良い
書き方が思い付きません。

現在の私の知識では、以前こちらでご教授頂いた
下記の方法

Dim x As Range
Dim sum

sum = 0

For Each x In Sheets(1).Range("A:A")
If x.Value = 201 _
And (x.Offset(0, 1).Value = 1 Or _
x.Offset(0, 1).Value = 4 Or x.Offset(0, 1).Value = 7 Or _
x.Offset(0, 1).Value = 8 Or x.Offset(0, 1).Value = 9) Then
sum = sum + x.Offset(0, 2).Value
End If

If x.Value = 503 _
And (x.Offset(0, 1).Value = 1 Or _
x.Offset(0, 1).Value = 4 Or x.Offset(0, 1).Value = 7 Or _
x.Offset(0, 1).Value = 8 Or x.Offset(0, 1).Value = 9) Then
sum = sum + x.Offset(0, 2).Value
End If
Next

Sheets(2).Range("A1").Value = sum
End Sub

しか分からないのですが、以前よりも仕事で扱う
コード数が増えてしまい、実際は集計条件のコード
が100ぐらいあり、
　If x.Value = 集計条件のコード
　　・・中略・・
　End If
を100近く書いて処理するのは、効率の面、速度の面からきびしくなってしまいました。

定数等を使ってやってみたものの上手くいかず煮詰まっています。
何とぞご教授よろしくお願いします。

回答No.1

anmochi · ベストアンサー

そうねぇ・・・・まずは、すぐできるとこからチューンしていきましょうか。

If x.Value = 503 And (x.Offset(0, 1).Value = 1 or x.Offset(0, 1).Value = 4 or x.Offset(0, 1).Value = 7 or x.Offset(0, 1).Value = 8 or x.Offset(0, 1).Value = 9) then
sum = sum + x.Offset(0, 2).value
Endif
の代わりに、
If x.Value = 503 Then
Select Case x.Offset(0, 1).Value
Case 1, 4, 7, 8, 9
sum = sum + x.Offset(0, 2).Value
End Case
End If
という構文が利用できる。さらに、x.Valueの201と503で、x.Offset(0, 1)の条件が変わらないのであれば、
Select Case x.Value
Case 201, 305 ' -[1]
Select Case x.Offset(0, 1).Value
Case 1, 4, 7, 8, 9
sum = sum + x.Offset(0, 2).Value
End Select
End Select
という風に、Select Case構文をx.Valueとx.Offset(0, 1).Valueに対して入れ子で書いてあげると、x.Valueの値が201と305の他に増えていっても、[1]の部分にその数字を追加してあげるだけで動作するようになる。

まぁ、残念ながらこれでは集計速度は変わらない。が、効率は格段に向上するはずだ。

' 修正後 全ソース
Dim x As Range
Dim sum
sum = 0
For Each x In Sheets(1).Range("A:A")
Select Case x.Value
Case 201, 305 ' -[1] 集計条件のコードが増えたら、ここにコードを追加する
Select Case x.Offset(0, 1).Value
Case 1, 4, 7, 8, 9
sum = sum + x.Offset(0, 2).Value
End Select
End Select
Next
Sheets(2).Range("A1").Value = sum
End Sub

今机上でプログラムを修正したので、実行テストはしていないのでよろしく。

お礼

ご教授ありがとうございます。
Select Case の構文を知ってはいたものの、このよう
な使い方があるとは思い付きませんでした。
もっと勉強いたします。
ありがとうございました。

回答No.2

Wendy02

こんにちは。
あまり、リテラル値によるコーディングは、大変になるばかりです。その都度、コードを変更するのは大変です。以下は、条件が変っても大丈夫なのかは分りませんが、検索値は、範囲で入力するように出来ています。

それと、
Sheets(1).Range("A:A")
65536 行目まで検索するよりは、データのあるところまでにしたほうがよいです。

'<標準モジュール>
Sub SearchSum()
With Sheet1
　Sheet2.Range("A1").Value = SearchNumbers(.Range("A1", .Range("A1").End(xlDown)), .Range("F2:G2"), .Range("F3:J3"))
End With
End Sub
Function SearchNumbers(DataRng As Range, Arg1 As Range, Arg2 As Range)
'SearchNumbers(コード,コード検索値,対象区分値)
　 Dim Ary1() As Variant
　 Dim Ary2() As Variant
　 Dim i As Integer
　 Dim j As Integer
　 Dim ret As Integer
　 Dim ret2 As Integer
　 Dim c As Range
　 Dim myTotal As Double
　 ReDim Ary1(1 To Arg1.Count)
　 ReDim Ary2(1 To Arg2.Count)
　 '１次元にする
　 For i = 1 To Arg1.Count
　　　Ary1(i) = Arg1.Cells(i)
　 Next i
　 For j = 1 To Arg2.Count
　　　Ary2(j) = Arg2.Cells(j)
　 Next j
　 For Each c In DataRng
　　　If VarType(c) = vbDouble Then
　　　　 On Error Resume Next
　　　　 ret = 0
　　　　 ret = WorksheetFunction.Match(c.Value, Ary1(), 0)
　　　　 If ret > 0 Then
　　　　　　ret2 = 0
　　　　　　ret2 = WorksheetFunction.Match(c.Offset(, 1).Value, Ary2(), 0)
　　　　　　If ret2 > 0 Then
　　　　　　　 'オフセットは、最初の列に対して二つ右へ
　　　　　　　 myTotal = myTotal + c.Offset(, 2).Value
　　　　　　　 On Error GoTo 0
　　　　　　End If
　　　　 End If
　　　End If
　 Next c
　 SearchNumbers = myTotal
End Function

お礼

ご教授ありがとうございます。
高度な技の数々でびっくりしました。
私の知識不足で大変申し訳ないのですが、条件が
変わった場合、どのように修正したら良いのか、
今の私では分からないほど高度な技でした。
このような理由で、本来ならば20ポイント差し上げ
なければならないのですが、10ポイントにさせて
頂きました。
どうぞ、お気を悪くなさらないでください。
これから私も、貴方様のような高度な技を使える
ようにＶＢＡを勉強していきたいと思います。
また質問させて頂いた時には、ご協力よろしく
お願いいたします。
ありがとうございました。