エクセルVBAでSUMPRODUCT関数の代用

質問

いつもお世話になっております。

現在、ある表の集計結果を返す際にマクロで
以下のような記述をしております。

Tate = Application.WorksheetFunction.CountA(Worksheets("アイテムリスト").Range("A:A"))

Worksheets("アイテムリスト").Range("D2").Value = "=SUMPRODUCT((日付CSV貼付用!$AG$2:$AG$60000=D$1)*(日付CSV貼付用!$P$2:$P$60000=$A2),(日付CSV貼付用!$S$2:$S$60000))"

Range("D2").Select
Selection.Copy

Range(Cells(2, 4), Cells(Tate, 4)).Select
ActiveSheet.Paste
Application.CutCopyMode = False

＝＝＝＝
D2にSUMPRODUCT関数を入力して、必要な分だけ下にコピーしてます。

もう少しスマートというかVBA的な記述で
作業（計算）時間の短縮を図りたいと考えています。
お知恵をお貸しいただきたく、お願い申し上げます。

回答No.5

zap35 · ベストアンサー

まずは今のマクロで少しでも計算範囲を少なくする方法です。
Sub Macro1()
Dim LastRow As Long
Tate = Application.WorksheetFunction.CountA(Worksheets("アイテムリスト").Range("A:A"))
LastRow = Worksheets("日付CSV貼付用").Range("A65536").End(xlUp).Row '追加
Worksheets("アイテムリスト").Range("D2").Formula _
= "=SUMPRODUCT((日付CSV貼付用!$AG$2:$AG$" & LastRow & _
"=D$1)*(日付CSV貼付用!$P$2:$P$" & LastRow & _
"=$A2),(日付CSV貼付用!$S$2:$S$" & LastRow & "))"

Range("D2").Copy
Range(Cells(2, 4), Cells(Tate, 4)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

またはこんな方法はどうでしょう
１．日付CSV貼付用シートのAG列がアイテムリストシートのD1と一致する行だけを抜き出す（フィルタオプションの機能）
２．抜き出したデータからアイテムリストを集計

Sub Macro2()
Dim Org As Worksheet
Dim LastR, frR, toR, idx As Long
Dim rngP, rngS As Range
' Application.ScreenUpdating = False
'日付CSV貼付用シートをコピー
　Worksheets("日付CSV貼付用").Copy before:=Worksheets("日付CSV貼付用")
'フィルタオプションでAG列がD1と一致するものだけを抽出
　Rows("1:3").Insert
　Rows(4).Copy Destination:=Range("A1")
　Range("AG2").Value = Worksheets("アイテムリスト").Range("D1").Value
　LastR = Range("A65536").End(xlUp).Row
　Range("A4:AG" & LastR).AdvancedFilter Action:=xlFilterCopy, _
　　　　CriteriaRange:=Range("A1:AG" & 2), _
　　　　CopyToRange:=Cells(LastR + 5, 1).Resize(1, 33), Unique:=False
'抽出データのP列、S列をレンジオブジェクトにセット
　toR = Range("A65536").End(xlUp).Row
　Set rngP = Range(Cells(LastR + 5, "P"), Cells(toR, "P"))
　Set rngS = Range(Cells(LastR + 5, "S"), Cells(toR, "S"))
'アイテムリストシートに集計値を書き込む
　With Worksheets("アイテムリスト")
　　For idx = 2 To .Range("A65536").End(xlUp).Row
　　　.Cells(idx, "D").Value = Application.SumIf(rngP, .Cells(idx, "A"), rngS)
　　Next idx
　End With
'後処理
' Application.DisplayAlerts = False
' ActiveSheet.Delete
' Application.DisplayAlerts = True
' Application.ScreenUpdating = True
End Sub

動作が確認しやすいように冒頭の画面描画停止、末尾の後処理はコメントにしています。どちらのシートも１行目がタイトル行であると想像してマクロを書いています。特に日付CSV貼付用シートはフィルタオプションを利用する関係上、必ず各列にタイトルを入れてください

お礼

ご教示ありがとうございます。

前半の方法で無駄に参照していた範囲を
最小限にすることができて、
喫緊の課題は解消できました。

後半部分も実験してみようと思います。

回答No.4

NauticA

範囲に名前を付けて記述するのも良いのではないでしょうか
余計な範囲を参照しなくなる分は効果があると思います。

日付CSV貼付用シートの列あたまに見出しを１行いれて
表内のセルを一つ選択した状態で

Selection.CurrentRegion.Select
Selection.CreateNames Top:=True, Left:=False, Bottom:=False, Right:=False

などとすれば
見出しが AG列、P列、S列などの場合は
"=SUMPRODUCT((AG列=D$1)*(P列=$A2),(S列))"
といった記述ができるようになります。

回答No.3

imogasi

基本に立ち返り、プリミチブに考えてみました。
SUMPRODUCT関数は、2つの利用タイプ、すなわち
（１）本来の使い方
対応する行（列の場合もある。以下行を念頭に置く）の２つ以上の掛け算の和（積和）ΣAi*Bi　A,Bは列、i は行といえようか。
（２）エクセルに２条件以上該当対象セルを数える関数が無いので（２００３まで）、便利技として、　TRUEX数値＋FALSEｘ数値＋・・のような考え方を使う。TRUEは１、FALSEは０として計算されるので好都合。
の２つがあります。
ーー
A　本質問は上記（２）の利用らしいので、
B　同一行の複数列データを判別しているようなので
For i=1 to 10000
If Cells(i,"A")=X And Cells(i,"C")=Y And Cells(i,"D")=Z Then
処理１
Else
処理２
Next i
とやれば済むと思う。
エクセルの関数の中には、各行ごとの繰り返し法に（泥臭く）還元できるものが沢山ある。特にセル範囲を使うものはそうです。
（１）繰り返し法
（２）ワークシート関数法、ユーザー関数法
（３）メソッドを利用
（４）ウイザード利用法
検索では（１）で毎セルForNext、ForEachで聞く
（２）Match関数
（３）Findメソッド
（４）この例ではないが、ピボットテーブルなど利用
を思い出せば、役立つと思う。
コード行数は（２）（３）は少なく一見して、何をしているか、
ベテランにはわかりやすいが、本当の実行は探索を繰り返しているかも知れないので、私らにはスピードのことを言われても、やってみるしかなかろう。（２）は自動再計算に備えているせいで、行数が多いと一般的には、破綻しやすいと思う。

回答No.2

Wendy02

こんにちは。

>作業（計算）時間の短縮を図りたいと考えています。

今、試してみると、30,000行で、もうハングアップしましたね。

おそらく、そのマクロは使えないと思います。

問題は数式の使い方なのです。

日付CSV貼付用!$AG$2:$AG$60000=D$1

上位バージョンでも配列のデータ個数は、約5,000個程度にしておいたほうがよいと、私は考えています。一般関数はデータのない場所は、セルとして扱いませんが、配列数式は、データのないところでも、存在するデータとして処理してしまうのではないかと思います。

そうすると、非常にワークシートに対して負担になるのではないでしょうか？
本来、その配列数式ではなくて、データベース関数のほうがよいのではないか、と思います。そうすれば、一括して、合計が取れるはずです。(例：DSUM)

今回は、マクロというのがご所望なので、その数式自体をマクロにしてしまいました。
あまり、速度的にはお約束できませんが、数が多くても可能です。ただし、数式ではありませんから、変更があれば、その都度、マクロで集計しなければなりません。

Sub TestMacro()
Dim i As Long
Dim LastRow As Long
Dim Arg1 As Variant
Dim Arg2 As Variant

LastRow = Worksheets("アイテムリスト").Range("A65536").End(xlUp).Row
'検索データ
Arg1 = Worksheets("アイテムリスト").Range("D1").Value
Arg2 = Worksheets("アイテムリスト").Range("A2").Value

Application.ScreenUpdating = False
With Worksheets("日付CSV貼付用")
For i = 2 To LastRow
　 'AG列とP列
　 If .Cells(i, 33).Value = Arg1 And .Cells(i, 16).Value = Arg2 Then
　　　　Worksheets("アイテムリスト").Cells(i, 4) = .Cells(i, 19).Value　'D列
　 End If
Next i
End With

Application.ScreenUpdating = False
End Sub

回答No.1

zap35

＞もう少しスマートというかVBA的な記述で
＞作業（計算）時間の短縮を図りたいと考えています。

もう少し背景や目的を明確にしていただく方が良いと思います。
日付CSV貼付用シートやアイテムリストシートの項目数によっても回答が変わるかもしれませんよ

＞日付CSV貼付用!$AG$2:$AG$60000
本当に60000行までデータがあるなら、シートを見直さない限りどんな方法でも早くはできないかもしれませんが…

補足

ご指摘ありがとうございます。

日付CSV貼付用シートは
現時点では最大3,000行ぐらいです。
ただSUMPRODUCTは列全体を指定できないみたいですので
倍にしてます。

アイテムリストシートは
数十件といったところです。