[發問] 2個條件的加總

yliu

請問各位高手,

我要將原始資料裡依類別與日期這兩個條件將金額加總到"總表",例如:1/1~1/31, A類金額加總後放到B4儲存格,2/1~2/28, A類金額加總後放到C4儲存格,3/1~3/31, A類金額加總後放到D4儲存格..以此類推
原本使用工作表函數SUMPRODUCT, 但資料量多時,工作表run重新計算會花很多時間, 想改用VBA方式.
但我只會用下列寫法,發現這樣寫法要寫很多的IF判斷,想請問各位高手 提供較好的寫法.感謝!

Private Sub CommandButton2_Click()
Dim rowcnt As Integer
Dim i As Integer
Dim sum_A_1, sum_A_2, sum_A_3,sum_A_4,sum_A_5,sum_A_6,sum_A_7,sum_A_8,sum_A_9,sum_A_10,sum_A_11,sum_A_12 As Variant
sum_A_1= 0 '統計A類1月份金額
sum_A_2= 0 '統計A類2月份金額
sum_A_3= 0 '統計A類3月份金額
sum_A_4= 0 '統計A類4月份金額
sum_A_5= 0 '統計A類5月份金額

Sheets("原始資料").Activate
With Sheets("原始資料")
rowcnt= .Cells(1, 1).CurrentRegion.Rows.Count

For i = 1 To rowcnt
    '加總A類一月份金額
    If .Cells(i,2) >= "2013/1/1"And .Cells(i, 2) <= "2013/1/31" And .Cells(i,1) = Sheets("總表").Range("A4") Then
        sum_A_1= sum_A_1 + (Cells(i, 3).Value)
        Sheets("總表").Range("B4") = sum_A_1
    End If
   '加總A類二月份金額
     If .Cells(i,2) >= "2013/2/1"And .Cells(i, 2) <= "2013/2/28" And .Cells(i,1) = Sheets("總表").Range("A4") Then
        sum_A_2= sum_A_2+ (Cells(i, 3).Value)
        Sheets("總表").Range("C4") = sum_A_2   
     End If
Next

End With
End Sub

下載 (59.32 KB)
原始資料

2013-5-30 23:04

下載 (62.72 KB)
總表

2013-5-30 23:06

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

執行前:

下載 (71.4 KB)

2023-4-26 16:44

執行結果:

下載 (150.53 KB)

2023-4-26 16:45

Option Explicit
Sub TEST()
Dim Brr, Crr, Y, i&, j&, T1$, T2$, T3%
Dim Sh1 As Worksheet, Sh2 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("原始資料"): Set Sh2 = Sheets("總表")
Brr = Range(Sh1.[C2], Sh1.Cells(Rows.Count, "A").End(3))
Sh2.[B4:R14].ClearContents: Crr = Sh2.[A3:R14]
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Format(Brr(i, 2), "M月"): T3 = Brr(i, 3)
   Y(T1 & "|" & T2) = Y(T1 & "|" & T2) + T3
Next
For i = 2 To UBound(Crr) - 1
   For j = 2 To 13: Crr(i, j) = 0 + Y(Crr(i, 1) & "|" & Crr(1, j)): Next
Next
With Sh2
   .[A3:R14] = Crr
   .[N4:N13] = "=SUM(B4:M4)"
   .[O4:O13] = "=SUM(B4:D4)"
   .[P4:P13] = "=SUM(E4:G4)"
   .[Q4:Q13] = "=SUM(H4:J4)"
   .[R4:R13] = "=SUM(K4:M4)"
   .[B14:R14] = "=SUM(B4:B13)"
End With
Set Y = Nothing: Set Sh1 = Nothing: Set Sh2 = Nothing: Erase Brr, Crr
End Sub

c_c_lai

回復 18# yliu
我將原本 Kimbal 版大提供的修正程式在予增修，
以及 sunnyso 前輩提供的程式略予修正後，寫成兩組
效益不錯的模組，供妳選用。
A.  之前提供的，改以陣列處理 (原本是對應實體欄位一一處理)，
       經修正後的程式碼：

1. Sub Ex_Match_Case()         '  Match Case
   
2.     Dim RowsCnt As Long, i As Long, SubTotalAr() As Double
   
3.     Dim t1 As Variant, t2 As Variant, AllType As Variant
   
4.     Dim DataArea As Variant, Atype As Integer
   
5.     Dim lngCurrenMonth As Long, lngCurrValue As Long
   
6. 
   
7.     t1 = Timer
   
8.     Application.ScreenUpdating = False
   
9.     '  Application.Calculation = xlCalculationManual
   
10. 
    
11.     AllType = Array("A類", "B類", "C類", "D類", "E類", "F類", "G類", "H類", "I類", "J類")
    
12.     ReDim SubTotalAr(0 To UBound(AllType), 0 To 16)
    
13.    '  清理舊數據
    
14.     Sheets("總表").Activate
    
15.     Sheets("總表").Range("A3").CurrentRegion.Offset(1, 1).Clear
    
16. 
    
17.     Sheets("原始資料").Activate
    
18.     With Sheets("原始資料")
    
19.         RowsCnt = .Cells(1, 1).CurrentRegion.Rows.Count
    
20.         DataArea = .Range("A2").Resize(RowsCnt - 1, 3)
    
21.         
    
22.         For i = 1 To UBound(DataArea)
    
23.             lngCurrenMonth = 0
    
24.             If IsDate(DataArea(i, 2)) Then
    
25.                 lngCurrenMonth = Month(DataArea(i, 2))                                               '  當行月份
    
26.             End If
    
27.             
    
28.             If lngCurrenMonth > 0 Then
    
29.                 lngCurrValue = DataArea(i, 3)
    
30.                         
    
31.                 For Atype = 0 To UBound(AllType)                '  A類 To J類
    
32.                     If DataArea(i, 1) = AllType(Atype) Then     '  Jan To Dec
    
33.                         SubTotalAr(Atype, lngCurrenMonth - 1) = SubTotalAr(Atype, lngCurrenMonth - 1) + lngCurrValue
    
34.                         SubTotalAr(Atype, 12) = SubTotalAr(Atype, 12) + lngCurrValue     '  累計
    
35.                         SubTotalAr(Atype, 13 + Int(lngCurrenMonth / 3.2)) = SubTotalAr(Atype, 13 + Int(lngCurrenMonth / 3.2)) + lngCurrValue
    
36.                         '  除以 3.2：
    
37.                         '  1 (Int(0.3125)=0)，  2 (Int(0.625))=0 )， 3 (Int(0.9375))=0 )，  '  第一季
    
38.                         '  4 (Int(1.25))=1)，   5 (Int(1.5625))= 1)，6 (Int(1.875 ))=1)，   '  第二季
    
39.                         '  7 (Int(2.1875))= 2)，8 (Int(2.5))=2 )，   9 (Int(2.8125))=2)，   '  第三季
    
40.                         '  10(Int(3.125))=3)，  11(Int(3.4375 ))=3)，12(Int(3.75))=3)       '  第四季
    
41.                         '  *************************************************************************************
    
42.                     End If
    
43.                 Next Atype
    
44.             End If
    
45.         Next i
    
46.     End With
    
47.    
    
48.     With Sheets("總表")
    
49.         .Range("B4").Resize(UBound(AllType) + 1, 17) = SubTotalAr
    
50.         '  RowsCnt = .[A3].End(xlDown).Row
    
51.         ' For i = 2 To 18
    
52.         '      .Cells(RowsCnt, i) = WorksheetFunction.Sum(.Range(Chr(64 + i) & 4 & ":" & Chr(64 + i) & (RowsCnt - 1)))   '  合計
    
53.         '  Next i
    
54.         .Range("B14:R14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    
55.     End With
    
56.    
    
57.     '  Application.Calculation = xlCalculationAutomatic
    
58.     Application.ScreenUpdating = True
    
59.     t2 = Timer
    
60.     '  MsgBox "耗時" & t2 - t1
    
61.     Sheets("原始資料").[F11] = "耗時： " & CDbl(t2 - t1)
    
62. End Sub

複製代碼

B.  經測試，效益最佳的程式模組：

1. Sub Ex_VBA_Array()          '  VBA Code DataArea Array
   
2.     Dim RowsCnt As Long, m As Long, SubTotalAr() As Double
   
3.     Dim t1 As Variant, t2 As Variant, AllType As Variant
   
4.     Dim DataArea As Variant
   
5.     Dim i%, j%
   
6.    
   
7.     t1 = Timer
   
8.     AllType = Array("A類", "B類", "C類", "D類", "E類", "F類", "G類", "H類", "I類", "J類")
   
9.     ReDim SubTotalAr(0 To UBound(AllType), 0 To 11)
   
10.     Application.ScreenUpdating = False
    
11.    
    
12.     '  清理舊數據
    
13.     '  Sheets("總表").Activate
    
14.     Sheets("總表").Range("A3").CurrentRegion.Offset(1, 1).Clear
    
15.    
    
16.     With Sheets("原始資料")
    
17.         RowsCnt = .Range("A1").CurrentRegion.Rows.Count
    
18.         DataArea = .Range("A2").Resize(RowsCnt - 1, 3)
    
19.         
    
20.         For m = 1 To UBound(DataArea)
    
21.             For i = 0 To UBound(AllType)                '  A類 To J類
    
22.                 If DataArea(m, 1) = AllType(i) Then     '  Jan To Dec
    
23.                     SubTotalAr(i, Month(DataArea(m, 2)) - 1) = SubTotalAr(i, Month(DataArea(m, 2)) - 1) + DataArea(m, 3)
    
24.                 End If
    
25.             Next i
    
26.         Next m
    
27.     End With
    
28.    
    
29.     With Sheets("總表")
    
30.         .Range("B4").Resize(UBound(AllType) + 1, 12) = SubTotalAr
    
31.         .Range("N4:N13").FormulaR1C1 = "=SUM(RC[-12]:RC[-1])"
    
32.         For i = 0 To 3
    
33.             '  .Range(Chr(79 + i) & 4 & ":" & Chr(79 + i) & 13).FormulaR1C1 = "=SUM(RC[-" & (13 - i * 2) & "]:RC[-" & (11 - i * 2) & "])"
    
34.             .Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1).FormulaR1C1 = "=SUM(RC[-" & (13 - i * 2) & "]:RC[-" & (11 - i * 2) & "])"
    
35.             .Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1) = .Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1).Value
    
36.         Next i
    
37.         .Range("B14:R14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
    
38.     End With
    
39.     Application.ScreenUpdating = True
    
40.     t2 = Timer
    
41.     '  MsgBox "耗時" & t2 - t1
    
42.     Sheets("原始資料").[F3] = "耗時： " & CDbl(t2 - t1)
    
43. End Sub

複製代碼

以上兩組模組，均使用 70 筆、以及 52,993 筆之資料 (sunnyso 前輩提供) 測試過。
妳可以自行測測看。

sunnyso

回復 20# yliu

類別陣列可以從總表讀取, 也可以從原始資料表A欄把不重復的讀出（例如字典法）

yliu

回復 16# sunnyso

請問: 程式碼中...Array("A類", "B類", "C類", "D類", "E類", "F類", "G類", "H類", "I類", "J類")
即若採用陣列,  就是當有新的類別項目時, 就需修改程式碼,例如：日後可能新增K類時, 就需修改程式是嗎？
那採用陣列方式就會受限制,是否有別的方式呢？

yliu

回復 14# sunnyso

目前累積資料是700筆左右, 到年底應該會有2000筆.
本來只知道SUMIF 函數, 但SUMIF函數只限用於單一條件, 謝謝提供SUMIFS.
但SUMIFS應該是2010版本才有的函數.

yliu

回復 15# c_c_lai

謝謝詳細說明

c_c_lai

回復 16# sunnyso
SUMIFS 的處理的確蠻簡潔的，值得研究及應用，
以往(工作)我是偏重於從事應用軟體與網頁應用方面，
從無機緣接觸過 Excel，退下後為幫助友人才開始接觸
Excel (新手)， 是故較少使用此類似之函數，
謝謝你的指教！ 它對我蠻有助益的，再次謝謝！

sunnyso

回復 15# c_c_lai

應該把資料一次讀入陣列, 然後在VBA中計算成陣列,最後把計算好的陣列回傳到工作表。
減少物件讀寫次數VBA的效率才高

目前發現VBA的效率比SUMIFS低

可以參考這裏
http://forum.twbts.com/thread-9607-1-1.html

c_c_lai

回復  c_c_lai


   謝謝 c_c_lai,
   可以使用了, 感謝~
  再請問一下,   
.Cells(lngVlookupRow, ...
yliu 發表於 2013-5-31 23:53

如果除以 4：
1  ( Int(0.25)=0)， 2 ( Int(0.5))=0 )，     3( Int(0.75))=0 )，  '   第一季 (應為 0)
4(  Int(1))=1)，      5( Int(1.25))= 1)，    6( Int(1.5 ))=1)，    '   第二季 (應為 1)
7( Int(1.75))= 1)， 8( Int(2))=2 )，         9(  Int(2.25))=2)，   '  第三季 (應為 2)
10(  Int(2.5))=2)， 11( Int(2.75 ))=2)，12(  Int(3))=3)          '  第四季 (應為 3)
除以 3.2：
1  ( Int(0.3125)=0)， 2 ( Int(0.625))=0 )，     3( Int(0.9375))=0 )， '   第一季
4(  Int(1.25))=1)，      5( Int(1.5625))= 1)，   6( Int(1.875 ))=1)，    '   第二季
7( Int(2.1875))= 2)， 8( Int(2.5))=2 )，           9(  Int(2.8125))=2)， '  第三季
10(  Int(3.125))=3)， 11( Int(3.4375 ))=3)，12(  Int(3.75))=3)       '  第四季
結論： .Cells(lngVlookupRow, Chr(79 + Int(lngCurrenMonth / 3.2))) =
              .Cells(lngVlookupRow, Chr(79 + Int(lngCurrenMonth / 3.2))) + lngCurrValue
1月  ：.Cells(lngVlookupRow, Chr(79 + 0)) = .Cells(lngVlookupRow, Chr(79 + 0)) + lngCurrValue
             .Cells(lngVlookupRow, "O") = .Cells(lngVlookupRow, "O") + lngCurrValue    '  第一季
7月  ：.Cells(lngVlookupRow, Chr(79 + 2)) = .Cells(lngVlookupRow, Chr(79 + 2)) + lngCurrValue
             .Cells(lngVlookupRow, "Q") = .Cells(lngVlookupRow, "Q") + lngCurrValue    '  第三季
11月：.Cells(lngVlookupRow, Chr(79 + 3)) = .Cells(lngVlookupRow, Chr(79 + 3)) + lngCurrValue
             .Cells(lngVlookupRow, "R") = .Cells(lngVlookupRow, "R") + lngCurrValue     '  第四季
此論得知，如以 3.2 作為分母除之、再以 Int() 來過濾，得值得以正確顯示，不致歸類錯誤。