マクロ・複数の条件から一致する合計を求めたい。

質問

マクロ初心者です。
現在SUMIF関数で一致する条件を集計しているのですが、件数が多く処理が重くなってしまい困っています。
ピポットテーブルの使用も検討したのですが、表を参照して別ブックに反映させる事がある為、使用する事を断念しました。
今回、解決したい内容は・・・
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
sheets("データ")には
A3から「受注した日付」、B3から「発送日」、C3から「取引先」、D3から「商品名」、E3から「=A3&B3&C3&D3」※受注日＋発送日＋取引先＋商品名、F3から「=B3&C3&D3」※発送日＋取引先＋商品名、G3から「=C3&D3」※取引先＋商品名、H3から受注数を一覧(下へ)表示しております。
シートはそれぞれ、sheets("受注日累計")、sheets("発送日累計")、sheets("累計")があり、sheets("受注日累計")にはE3のデータをSUMIFで参照して一致するものの合計値を、sheets("発送日累計")にはF3のデータをSUMIFで参照して一致するものの合計値を、sheets("累計")にはG3のデータをSUMIFで参照して一致するものの合計値を表示しております。
※それぞれD7セルから。

その為、処理に非常に時間がかかりますので、関数を使用せず集計ボタン一つで、処理が重く成らない様、集計出来るようにしたいのですが・・・

どうか無能な私にご教授の程、宜しくお願いいたします。

エクセルは2003を使用しております。

回答No.9

cj_mover · ベストアンサー

こんにちは。お邪魔します。

ちょっと難度高いので短期間で自作できるよう導く自信がないので、
暫定で使って貰えるようにこちらで書いてみました。
27000件のサンプルで動作確認していますが、
実行環境や実際のファイルのあり方によってはメモリ不足も
あり得ないこともないです（たぶん大丈夫？）。
ＶＢＡ的には、遅くはない、程度ですが、
SUMIF()と比べれば、断然速い筈です（手元の環境＋ブックでは約0.7秒）。
もし使い物にならないようでしたら、
他の方法で書き直してみようかな？、とも思っています。
とりあえずは、そのままコピペで動くように書いていますので、
試すだけでもしてみてください。
どんな感じか雰囲気だけでも感じとって貰えれば、と思います。

条件や仕様への私の理解が完全とは言えないので、こちらが誤解していれば
期待しされているものとは多少違うかも知れません。
出力先のセル位置や出力の仕方などは、明確に把握できていませんので。

試す場合は、
まず、予めコピーしたブックで、
Sub Re8076330()を
どこか適当なモジュールに貼り付けて、
一旦、適当な名前で保存してから、
実行してみてください。

Accessでいうレポートにあたる内容を
すべて更新、上書きする形でシートに返すという理解でいます。
簡単に処理の流れだけコメント化して説明しておきます。
そちらで動作確認の上、調整・修正が難しいようでしたら、
具体的な条件・仕様の相違などを補足してみてください。

技術的な内容としては
　Worksheet の扱い
　Range の扱い
　配列変数 の扱い
　Scripting.Dictionary の扱い
初～中級の技術の組み合わせです。
Scripting.Dictionary については、このサイトでも、
過去にたくさんの回答が付けられています。
基本的な部分は教則サイトで覚えるとして、
応用的な部分についても資料・情報に困ることはないと思います。
比較的メジャーだという意味で選んだ手法ですので。
もし、このままお使いになるようでしたら、できれば、やがては、
ご自分でメンテ出来るように覚えていって貰えるとい嬉しいのですけど。

# 因みに、ですが、
sheets("データ") の　=A3&B3&C3&D3　などの数式についても、
数式に頼らず、ＶＢＡで対応する方が何かと軽くできます。
余裕が出来たら検討してみると良いと思います。。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

' ' ■　参照設定　Microsoft Scripting Runtime　■
Sub Re8076330()
　　Const S__PR_SHEET = " 受注日累計 発送日累計 累計"
' ' ↑　出力先シート名を半角スペース区切りで指定　↑（※先頭に半角スペース）
　　Dim mtxS()
　　Dim mtxP()
　　Dim arrK()
　　Dim arrI()
　　Dim arrPrSh
'　　Dim oDict As Scripting.Dictionary ' ■参照設定■した場合
　　Dim oDict As Object ' ■参照設定■しなかった場合
　　Dim tnRows As Long
　　Dim tnUb As Long
　　Dim tnUniq As Long
　　Dim nBtm As Long
　　Dim iPR As Long
　　Dim i As Long

' ' 元データを配列変数に格納
　　tnRows = Rows.Count
　　With Sheets("データ")
　　　　mtxS = .Range("E3:H" & .Cells(tnRows, 1).End(xlUp).Row).Value
　　End With
　　tnUb = UBound(mtxS)
' ' 出力先シート名を配列に
　　arrPrSh = Split(S__PR_SHEET)
' ' Dictionary オブジェクトを設定
'　　Set oDict = New Scripting.Dictionary ' ■参照設定■した場合
　　Set oDict = CreateObject("Scripting.Dictionary") ' ■参照設定■しなかった場合
' ' シートをループ
　　For iPR = 1 To 3
' ' 重複しないKeyを作成しつつItemで累計を計算
　　　　For i = 1 To tnUb
　　　　　　oDict(mtxS(i, iPR)) = oDict(mtxS(i, iPR)) + mtxS(i, 4)
　　　　Next i
' ' Dictionary の中身を一旦、一次元の配列変数に格納
　　　　With oDict
　　　　　　tnUniq = .Count
　　　　　　arrK = .Keys
　　　　　　arrI = .Items
　　　　　　.RemoveAll
　　　　End With
' ' 一次元の配列変数から出力用の二次元の配列変数に
　　　　ReDim mtxP(1 To tnUniq, 1 To 2)
　　　　For i = 1 To tnUniq
　　　　　　mtxP(i, 1) = arrK(i - 1)
　　　　　　mtxP(i, 2) = arrI(i - 1)
　　　　Next i
　　　　Erase arrK, arrI
' ' 出力シートの既存レポートをクリア→配列データを一括出力
　　　　With Sheets(arrPrSh(iPR))
　　　　　　nBtm = .Cells(tnRows, "D").End(xlUp).Row
　　　　　　If nBtm > 6 Then .Range("D7:E" & nBtm).Value = Empty
　　　　　　.Range("D7:E" & tnUniq + 6).Value = mtxP
　　　　End With
　　　　Erase mtxP
　　Next iPR
　　Set oDict = Nothing
　　Erase mtxS, arrPrSh
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

お礼

ご回答ありがとうございます！！
問題が解決いたしました！！
数日間あの手この手で色々試しましたが、やっと前に進む事ができます。
本当にありがとうございました。

回答No.8

tom04

こんばんは！
一例です。

Alt+F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt+F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から
Dim i As Long, k As Long, endRow As Long, cnt As Long, wS As Worksheet
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "作業用"
Set wS = Worksheets("作業用")
Application.ScreenUpdating = False
With Worksheets("データ")
'「受注日累計」Sheet用
.Range("E:E").AdvancedFilter Action:=xlFilterInPlace, unique:=True
i = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(3, 5), .Cells(i, 5)).Copy
wS.Activate
ActiveSheet.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow = Worksheets("受注日累計").Cells(Rows.Count, "D").End(xlUp).Row
If endRow > 6 Then
Range(Worksheets("受注日累計").Cells(7, "D"), Worksheets("受注日累計").Cells(endRow, "D")).ClearContents
End If
cnt = 6
For k = 1 To wS.Cells(Rows.Count, 1).End(xlUp).Row
.Range("E:E").AutoFilter field:=1, Criteria1:=wS.Cells(k, 1)
cnt = cnt + 1
Worksheets("受注日累計").Cells(cnt, "D") = WorksheetFunction.Subtotal(9, .Range("H:H"))
Next k
'「発送日累計」Sheet用
wS.Range("A:A").ClearContents
.Range("F:F").AdvancedFilter Action:=xlFilterInPlace, unique:=True
i = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(3, 6), .Cells(i, 6)).Copy
wS.Activate
ActiveSheet.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow = Worksheets("発送日累計").Cells(Rows.Count, "D").End(xlUp).Row
If endRow > 6 Then
Range(Worksheets("発送日累計").Cells(7, "D"), Worksheets("発送日累計").Cells(endRow, "D")).ClearContents
End If
cnt = 6
For k = 1 To wS.Cells(Rows.Count, 1).End(xlUp).Row
.Range("F:F").AutoFilter field:=1, Criteria1:=wS.Cells(k, 1)
cnt = cnt + 1
Worksheets("発送日累計").Cells(cnt, "D") = WorksheetFunction.Subtotal(9, .Range("H:H"))
Next k
'「累計」Sheet用
wS.Range("A:A").ClearContents
.Range("G:G").AdvancedFilter Action:=xlFilterInPlace, unique:=True
i = .Cells(Rows.Count, 1).End(xlUp).Row
Range(.Cells(3, 7), .Cells(i, 7)).Copy
wS.Activate
ActiveSheet.Cells(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteValues
endRow = Worksheets("累計").Cells(Rows.Count, "D").End(xlUp).Row
If endRow > 6 Then
Range(Worksheets("累計").Cells(7, "D"), Worksheets("累計").Cells(endRow, "D")).ClearContents
End If
cnt = 6
For k = 1 To wS.Cells(Rows.Count, 1).End(xlUp).Row
.Range("G:G").AutoFilter field:=1, Criteria1:=wS.Cells(k, 1)
cnt = cnt + 1
Worksheets("累計").Cells(cnt, "D") = WorksheetFunction.Subtotal(9, .Range("H:H"))
Next k
.AutoFilterMode = False
.Activate
End With
Application.DisplayAlerts = False
Worksheets("作業用").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub 'この行まで

※　一旦マクロを実行すると元に戻せませんので、別Bookに各シートをコピー＆ペーストして
マクロを試してみてください。m(_ _)m

お礼

ご回答ありがとうございます。
おかげ様で問題が解決いたしました！！
ただ、今回はNo.9さんのマクロを使用させていただきます。
本当にありがとうございました。

回答No.7

rainbow_note

＃１です。表記方法に間違いが有りました。申し訳ありません。

（訂正）
＜受注日累計＞
オートフィルタ後、Ａ列を検索したい受注日（または受注期間）にしてSUBTOTAL関数で合計表示させる。

＜発送日累計＞
オートフィルタ後、Ｂ列を検索したい発送日（または発送期間）にしてSUBTOTAL関数で合計表示させる。

（補足）
推測ですが2003を使われているということですと、OSはXP、５年前位前のＰＣではないでしょうか。
だとすれば、実際データ量が多くなればなるほど、スペック不足の問題も考え、対応していく必要があります。

私もExcel・Accessでプログラミングをした経緯がありますが、VBA初心者だとこういった集計を作るのはハードルが高いでしょう。
あと、Excelに下手にVBAを組み込んだりシートを多くすればＰＣ環境によってはスペック不足になることもあります。メモリ不足のメッセージが出たら危険信号です（経験上）。

IF文やSUMIFを使うやり方など他にも色々方法がありますので、他にも考えたのですが、やはり提示した方法が一番ベストですね。

Ａ列～Ｄ列はそのままにし、Ｈ列のデータをＥ列にもってきて、Ｅ列（受注数）の最後に累計欄をつけてSUBTOTAL関数で合計させるだけ。
そしてオートフィルタを行なってから条件抽出すればそんなに難しい手間がかかりません。

式もあまりない上にsheets("データ")のみで済むので、ＰＣに負荷もかからないと思います。

オートフィルタとSUBTOTAL関数の組み合わせは、検索で機能を調べると結構応用できるので、覚えておくといいと思います。

お礼

数回にわたりご回答いただき誠にありがとうございました。
今回はマクロを使用して問題解決に至りました。
オートフィルタとSUBTOTAL関数の組み合わせもかなり使えそうです！！他の集計表に使用させていただきました！
本当にありがとうございました。

回答No.6

KURUMITO

回答Ｎｏ４，５です。
ＳＵＭＩＦ関数をデータシートの中で使うようにしてはどうでしょう。試験してみてください。
列を新たに追加してＧ列、Ｊ列、Ｍ列を作ります。
Ｇ３セルには次の式を入力して下方にドラッグコピーします。

=IF(F3="","",IF(COUNTIF(F$3:F3,F3)=1,SUMIF(F:F,F3,N:N),""))

Ｊ３セルには次の式を入力して下方にドラッグコピーします。

=IF(I3="","",IF(COUNTIF(I$3:I3,I3)=1,SUMIF(I:I,I3,N:N),""))

Ｍ3セルには次の式を入力して下方にドラッグコピーします。

=IF(L3="","",IF(COUNTIF(L$3:L3,L3)=1,SUMIF(L:L,L3,N:N),""))

受注日累計シートのＡ3セルには次の式を入力してＥ3セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX(データ!$F:$F),"",IF(COLUMN(A1)<=4,INDEX(データ!$A:$D,MATCH(ROW(A1),データ!$F:$F,0),COLUMN(A1)),INDEX(データ!$G:$G,MATCH(ROW(A1),データ!$F:$F,0))))

発送日累計シートのＡ3セルには次の式を入力してＤ3セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX(データ!$I:$I),"",IF(COLUMN(A1)<=3,INDEX(データ!$B:$D,MATCH(ROW(A1),データ!$I:$I,0),COLUMN(A1)),INDEX(データ!$J:$J,MATCH(ROW(A1),データ!$I:$I,0))))

累計シートのＡ3セルには次の式を入力してＣ3セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX(データ!$L:$L),"",IF(COLUMN(A1)<=2,INDEX(データ!$C:$D,MATCH(ROW(A1),データ!$L:$L,0),COLUMN(A1)),INDEX(データ!$M:$M,MATCH(ROW(A1),データ!$L:$L,0))))

式を入力した段階では時間がかかりますが、その後に新たなデータがデータシートに追加されればそれぞれのシートの表も変わるわけですがその時の時間がどの程度かかるかですね。少しは改善されましたでしょうか？

お礼

数回にわたりご回答いただき誠にありがとうございました。
今回はマクロを使用して問題解決に至りましたが、
ご教授いただきました数式は他に流用させていただきます。
本当にありがとうございました。

回答No.5

KURUMITO

データの量がかなり多くなっていますね。
しかし関数処理に比べて計算が複雑になることからむしろマクロによる処理が遅くなると思いますね。

お礼

数回にわたりご回答いただき誠にありがとうございました。
今回はマクロを使用して問題解決に至りましたが、
ご教授いただきました数式は他に流用させていただきます。
本当にありがとうございました。

回答No.4

KURUMITO

データを処理するため作業列を作って対応しています。ところでお示しの方法ではＳＵＭＩＦ関数にかなりの負担がかかっています。そのために処理速度が極端に遅くなっています。マクロを採用したからといって処理速度が速くなるとは限りません。むしろ遅くなってしまうようなことになるでしょう。
ＳＵＭＩＦ関数に負担のかからない方法が必要です。せっかく作業列を作っているのですからもう一つの工夫が必要でしょう。作業列をもう一段設けることです。
Ｅ，Ｆ，Ｇ列に現在ある作業列のそれぞれの間に新たに列の挿入を行います。Ｅ列は従来のままで、Ｆ列は新規の列、Ｇ列は従来のＦ列で、Ｈ列は新規の列、Ｉ列は従来のＧ列で、Ｊ列は新規の列、Ｋ列は従来のＨ列になります。
Ｆ2セルには次の式を入力して下方にドラッグコピーします。

=IF(E3="","",IF(COUNTIF(E$3:E3,E3)=1,MAX(F$2:F2)+1,INDEX(F$2:F2,MATCH(E3,E$2:E2,0))))

Ｈ2セルには次の式を入力して下方にドラッグコピーします。

=IF(G3="","",IF(COUNTIF(G$3:G3,G3)=1,MAX(H$2:H2)+1,INDEX(H$2:H2,MATCH(G3,G$2:G2,0))))

Ｊ3セルには次の式を入力して下方にドラッグコピーします。

=IF(I3="","",IF(COUNTIF(I$3:I3,I3)=1,MAX(J$2:J2)+1,INDEX(J$2:J2,MATCH(I3,I$2:I2,0))))

そこで受注日累計のシートでは例えばＡ2セルから受注日　発送日　取引先 商品名 受注数の項目名をＥ2セルまで入力します。
Ａ3セルには次の式を入力してＥ3セルまで横にドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX(データ!$F:$F),"",IF(COLUMN(A1)<=4,INDEX(データ!$A:$D,MATCH(ROW(A1),データ!$F:$F,0),COLUMN(A1)),SUMIF(データ!$F:$F,ROW(A1),データ!$K:$K)))

Ａ列およびＢ列にはシリアル値が表示されますのでセルの表示形式を日付に変更します。

発送日累計のシートも同様にＡ2セルから発送日 取引先 商品名 受注数の項目名をＤ2セルまで入力します。
Ａ3セルには次の式を入力してＤ3セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX(データ!$H:$H),"",IF(COLUMN(A1)<=3,INDEX(データ!$B:$D,MATCH(ROW(A1),データ!$H:$H,0),COLUMN(A1)),SUMIF(データ!$H:$H,ROW(A1),データ!$K:$K)))

累計のシートも同様にＡ2セルから取引先 商品名 受注数の項目名をＣ2セルまで入力します。
Ａ3セルには次の式を入力してＣ3セルまでドラッグコピーしたのちに下方にもドラッグコピーします。

=IF(ROW(A1)>MAX(データ!$J:$J),"",IF(COLUMN(A1)<=2,INDEX(データ!$C:$D,MATCH(ROW(A1),データ!$J:$J,0),COLUMN(A1)),SUMIF(データ!$J:$J,ROW(A1),データ!$K:$K)))

このように作業列を新たに追加することでＳＵＭＩＦ関数の負担は極端少なくなり、これまでとは全く違った計算速度が得られることでしょう。

お礼

ご回答ありがとうございます。
検証させていただきましたが、やはり重くなりました。
データは日々追加されていきますので、3ヶ月周期・27000列程余裕を持たないといけない為、やはり非常に重たくなります。
それと、マクロでも重くなるのですね・・・

回答No.3

Nouble

横から済みません
Accessは詳しくないのですが、
開発が終わったものは
Accessが入っていないPcでも動かせる
とか、聞いたことがありますよ？

http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1014426765

お役に立てていたならば幸いです。

お礼

ご回答ありがとうございます。
参考になりました！！

回答No.2

kirakirasmaily

要するにやりたいことは、

１．受注日、発送日、取引先、商品名ごとの受注数
２．発送日、取引先、商品名ごとの受注数
３．取引先、商品名ごとの受注数

を求めたいだけですよね？

それならAccessにデータを放り込んでクエリかSQLを作成すれば一発だと思います。

たとえば、

１．受注日、発送日、取引先、商品名ごとの受注数を求める場合

SELECT
受注日, 発送日, 取引先, 商品名, SUM(受注数）
FROM
データ
GROUP BY
受注日, 発送日, 取引先, 商品名;

２．発送日、取引先、商品名ごとの受注数を求める場合

SELECT
発送日, 取引先, 商品名, SUM(受注数）
FROM
データ
GROUP BY
発送日, 取引先, 商品名;

３．取引先、商品名ごとの受注数を求める場合

SELECT
取引先, 商品名, SUM(受注数）
FROM
データ
GROUP BY
取引先, 商品名;

どうしてもエクセルでやりたいならマクロを作った方が良いと思いますけど、Accessでやるのが一番早いと思います。

お礼

ご回答ありがとうございます。
やっぱりAccessですよね・・・↓
すべてのPCがOffice professionalなら問題ないのですが・・・
私以外すべてpersonalの状況ですので、エクセルしか選択の余地が無いのが実情です・・・・
FileMakerを扱える人材もいるのですが、「簡単にできますよ」で一向に作成してくれない状況で・・・
畑違いの私が、不勉強ながら作成している所です↓
私はHTMLやCSSの用な簡単なのは書けるのですが、マクロは専門外で本当に参ってます。
本当にご回答ありがとうございました。

回答No.1

rainbow_note

かなり苦労されている様ですね。

やり方としては、オートフィルタとSUBTOTAL関数の組み合わせで処理すればうまくいけば、マクロも使わず１つのシートでいけそうな気がします。

SUBTOTAL関数は、非表示部分を計算しないSUM関数というイメージだと分かりやすいかも。

=SUBTOTAL(109,A1:A100)　109は固定

＜受注日累計＞
オートフィルタ後、Ａ３を検索したい受注日（または受注期間）にしてSUBTOTAL関数で合計表示させる。

＜発送日累計＞
オートフィルタ後、Ｂ３を検索したい発送日（または受注期間）にしてSUBTOTAL関数で合計表示させる。

なおSUBTOTAL関数の詳細はこちら。

参考URL：

http://www.excel.studio-kazu.jp/kw/20090219150110.html

お礼

ご回答ありがとうございます。
流石に今日は帰宅しましたので、明日検証させていただきます。
ご親切にご対応いただき、ありがとうございます。