麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 2個條件的加總 [打印本頁]

作者: yliu 時間: 2013-5-30 23:34 標題: 2個條件的加總

請問各位高手,

我要將原始資料裡依類別與日期這兩個條件將金額加總到"總表",例如: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

[attach]15113[/attach][attach]15115[/attach]

作者: kimbal 時間: 2013-5-31 01:38

本帖最後由 kimbal 於 2013-5-31 01:40 編輯

回復 1# yliu

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim rowcnt As Long
Dim i As Long
Dim lngVlookupRow As Long
Dim lngCurrenMonth As Long
Dim lngCurrValue As Long
'清理舊數據
Sheets("總表").Activate
Sheets("總表").Range("A3").CurrentRegion.Offset(1, 1).Clear
Sheets("原始資料").Activate
With Sheets("原始資料")
rowcnt = .Cells(1, 1).CurrentRegion.Rows.Count
For i = 1 To rowcnt
lngCurrenMonth = 0
If IsDate(.Cells(i, 2)) Then
lngCurrenMonth = Month(.Cells(i, 2)) '當行月份
End If
If lngCurrenMonth > 0 And Not (IsError(Application.Match(.Cells(i, 1), Sheets("總表").Range("A:A"), 0))) Then
lngVlookupRow = Application.Match(.Cells(i, 1), Sheets("總表").Range("A:A"), 0) '當行類型在總表行數
lngCurrValue = .Cells(i, 3)
With Sheets("總表").Cells(lngVlookupRow, lngCurrenMonth + 1) '放數據到總表上
.Value = .Value + lngCurrValue
End With
End If
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

複製代碼

作者: yliu 時間: 2013-5-31 12:30

回復 2# kimbal
謝謝kimbal.
但出現執行階段錯誤’13’: 型態不符合
偵錯在: With Sheets("總表").Cells(lngVlookupRow, lngCurrenMonth + 1) '放數據到總表上

作者: stillfish00 時間: 2013-5-31 13:07

回復 1# yliu
有考慮直接用樞紐分析表嗎?
[attach]15118[/attach]

作者: sunnyso 時間: 2013-5-31 13:10

回復 1# yliu

可以考慮用 SUMIFS 來代替 SUMPRODUCT，因爲SUMIFS更有效率

作者: kimbal 時間: 2013-5-31 13:27

回復 3# yliu

可否提供一下EXCEL?

另外也會建議用PIVOTTABLE 和SUMIFS
VBA LOOP很多情況也是比公式慢的.

作者: c_c_lai 時間: 2013-5-31 16:23

回復 kimbal
謝謝kimbal.
但出現執行階段錯誤’13’: 型態不符合
偵錯在: With Sheets("總表").Cells( ...
yliu 發表於 2013-5-31 12:30

回復 2# kimbal
不好意思，我稍微添加了幾行，希望您等能笑納！

Private Sub Ex()
Dim rowcnt As Long, i As Long
Dim lngVlookupRow As Long, lngCurrenMonth As Long, lngCurrValue As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' 清理舊數據
Sheets("總表").Activate
Sheets("總表").Range("A3").CurrentRegion.Offset(1, 1).Clear
Sheets("原始資料").Activate
With Sheets("原始資料")
rowcnt = .Cells(1, 1).CurrentRegion.Rows.Count
For i = 2 To rowcnt
lngCurrenMonth = 0
If IsDate(.Cells(i, 2)) Then
lngCurrenMonth = Month(.Cells(i, 2)) ' 當行月份
End If
If lngCurrenMonth > 0 And Not (IsError(Application.Match(.Cells(i, 1), Sheets("總表").Range("A:A"), 0))) Then
lngVlookupRow = Application.Match(.Cells(i, 1), Sheets("總表").Range("A:A"), 0) ' 當行類型在總表行數
lngCurrValue = .Cells(i, 3)
With Sheets("總表")
.Cells(lngVlookupRow, lngCurrenMonth + 1).Value = .Cells(lngVlookupRow, lngCurrenMonth + 1).Value + lngCurrValue ' 放數據到總表上
.Cells(lngVlookupRow, "N") = .Cells(lngVlookupRow, "N") + lngCurrValue
.Cells(lngVlookupRow, Chr(79 + Int(lngCurrenMonth / 4))) = .Cells(lngVlookupRow, Chr(79 + Int(lngCurrenMonth / 4))) + lngCurrValue
End With
End If
Next
End With
With Sheets("總表")
rowcnt = .[A3].End(xlDown).Row
For i = 2 To 18
.Cells(rowcnt, i) = WorksheetFunction.Sum(.Range(Chr(64 + i) & 4 & ":" & Chr(64 + i) & (rowcnt - 1)))
Next i
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

複製代碼

作者: c_c_lai 時間: 2013-5-31 19:52

本帖最後由 c_c_lai 於 2013-5-31 19:55 編輯

請將 4 改成 3.2

.Cells(lngVlookupRow, Chr(79 + Int(lngCurrenMonth / 3.2))) = .Cells(lngVlookupRow, Chr(79 + Int(lngCurrenMonth /3.2))) + lngCurrValue

複製代碼

作者: c_c_lai 時間: 2013-5-31 21:16

如附件：
[attach]15124[/attach]

作者: yliu 時間: 2013-5-31 23:53

回復 9# c_c_lai

謝謝 c_c_lai,
可以使用了, 感謝~
再請問一下,
.Cells(lngVlookupRow, Chr(79 + Int(lngCurrenMonth / 3.2))) = .Cells(lngVlookupRow, Chr(79 + Int(lngCurrenMonth / 3.2))) + lngCurrValue '

除以3.2 的作用是什麼?

作者: yliu 時間: 2013-6-1 00:02

回復 4# stillfish00

謝謝stillfish00, 因這檔案不只我使用, 所以希望能夠自動加總.已得到解答了,感謝!

作者: yliu 時間: 2013-6-1 00:03

回復 5# sunnyso

謝謝sunnyso, 試過你所提的SUMIFS, 可以使用.感謝!

作者: yliu 時間: 2013-6-1 00:05

回復 6# kimbal

c_c_lai 提供的程式碼已可以使用了,謝謝!
而sunnyso所提的SUMIFS確實也是一個方法.

作者: sunnyso 時間: 2013-6-1 00:25

回復 13# yliu
VBA用loop來做條件加總的效率並不會比SUMPRODUCT高

你的資料有多少筆？

作者: c_c_lai 時間: 2013-6-1 07:38

回復 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() 來過濾，得值得以正確顯示，不致歸類錯誤。

作者: sunnyso 時間: 2013-6-1 08:36

本帖最後由 sunnyso 於 2013-6-1 08:40 編輯

回復 15# c_c_lai

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

目前發現VBA的效率比SUMIFS低

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

作者: c_c_lai 時間: 2013-6-1 11:09

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

作者: yliu 時間: 2013-6-1 23:22

回復 15# c_c_lai

謝謝詳細說明

作者: yliu 時間: 2013-6-1 23:36

回復 14# sunnyso

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

作者: yliu 時間: 2013-6-1 23:54

回復 16# sunnyso

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

作者: sunnyso 時間: 2013-6-2 00:12

回復 20# yliu

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

作者: c_c_lai 時間: 2013-6-2 10:45

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

Sub Ex_Match_Case() ' Match Case
Dim RowsCnt As Long, i As Long, SubTotalAr() As Double
Dim t1 As Variant, t2 As Variant, AllType As Variant
Dim DataArea As Variant, Atype As Integer
Dim lngCurrenMonth As Long, lngCurrValue As Long
t1 = Timer
Application.ScreenUpdating = False
' Application.Calculation = xlCalculationManual
AllType = Array("A類", "B類", "C類", "D類", "E類", "F類", "G類", "H類", "I類", "J類")
ReDim SubTotalAr(0 To UBound(AllType), 0 To 16)
' 清理舊數據
Sheets("總表").Activate
Sheets("總表").Range("A3").CurrentRegion.Offset(1, 1).Clear
Sheets("原始資料").Activate
With Sheets("原始資料")
RowsCnt = .Cells(1, 1).CurrentRegion.Rows.Count
DataArea = .Range("A2").Resize(RowsCnt - 1, 3)
For i = 1 To UBound(DataArea)
lngCurrenMonth = 0
If IsDate(DataArea(i, 2)) Then
lngCurrenMonth = Month(DataArea(i, 2)) ' 當行月份
End If
If lngCurrenMonth > 0 Then
lngCurrValue = DataArea(i, 3)
For Atype = 0 To UBound(AllType) ' A類 To J類
If DataArea(i, 1) = AllType(Atype) Then ' Jan To Dec
SubTotalAr(Atype, lngCurrenMonth - 1) = SubTotalAr(Atype, lngCurrenMonth - 1) + lngCurrValue
SubTotalAr(Atype, 12) = SubTotalAr(Atype, 12) + lngCurrValue ' 累計
SubTotalAr(Atype, 13 + Int(lngCurrenMonth / 3.2)) = SubTotalAr(Atype, 13 + Int(lngCurrenMonth / 3.2)) + lngCurrValue
' 除以 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) ' 第四季
' *************************************************************************************
End If
Next Atype
End If
Next i
End With
With Sheets("總表")
.Range("B4").Resize(UBound(AllType) + 1, 17) = SubTotalAr
' RowsCnt = .[A3].End(xlDown).Row
' For i = 2 To 18
' .Cells(RowsCnt, i) = WorksheetFunction.Sum(.Range(Chr(64 + i) & 4 & ":" & Chr(64 + i) & (RowsCnt - 1))) ' 合計
' Next i
.Range("B14:R14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
End With
' Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
t2 = Timer
' MsgBox "耗時" & t2 - t1
Sheets("原始資料").[F11] = "耗時： " & CDbl(t2 - t1)
End Sub

複製代碼

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

Sub Ex_VBA_Array() ' VBA Code DataArea Array
Dim RowsCnt As Long, m As Long, SubTotalAr() As Double
Dim t1 As Variant, t2 As Variant, AllType As Variant
Dim DataArea As Variant
Dim i%, j%
t1 = Timer
AllType = Array("A類", "B類", "C類", "D類", "E類", "F類", "G類", "H類", "I類", "J類")
ReDim SubTotalAr(0 To UBound(AllType), 0 To 11)
Application.ScreenUpdating = False
' 清理舊數據
' Sheets("總表").Activate
Sheets("總表").Range("A3").CurrentRegion.Offset(1, 1).Clear
With Sheets("原始資料")
RowsCnt = .Range("A1").CurrentRegion.Rows.Count
DataArea = .Range("A2").Resize(RowsCnt - 1, 3)
For m = 1 To UBound(DataArea)
For i = 0 To UBound(AllType) ' A類 To J類
If DataArea(m, 1) = AllType(i) Then ' Jan To Dec
SubTotalAr(i, Month(DataArea(m, 2)) - 1) = SubTotalAr(i, Month(DataArea(m, 2)) - 1) + DataArea(m, 3)
End If
Next i
Next m
End With
With Sheets("總表")
.Range("B4").Resize(UBound(AllType) + 1, 12) = SubTotalAr
.Range("N4:N13").FormulaR1C1 = "=SUM(RC[-12]:RC[-1])"
For i = 0 To 3
' .Range(Chr(79 + i) & 4 & ":" & Chr(79 + i) & 13).FormulaR1C1 = "=SUM(RC[-" & (13 - i * 2) & "]:RC[-" & (11 - i * 2) & "])"
.Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1).FormulaR1C1 = "=SUM(RC[-" & (13 - i * 2) & "]:RC[-" & (11 - i * 2) & "])"
.Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1) = .Range(Chr(79 + i) & 4).Resize(UBound(AllType) + 1).Value
Next i
.Range("B14:R14").FormulaR1C1 = "=SUM(R[-10]C:R[-1]C)"
End With
Application.ScreenUpdating = True
t2 = Timer
' MsgBox "耗時" & t2 - t1
Sheets("原始資料").[F3] = "耗時： " & CDbl(t2 - t1)
End Sub

複製代碼

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

作者: Andy2483 時間: 2023-4-26 16:45

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

執行前:
[attach]36228[/attach]

執行結果:
[attach]36229[/attach]

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)