123
返回列表 上一主題 發帖

[發問] 2個條件的加總

yliu

帖子
49 
主題
8 
精華
0 
積分
63 
點名
0  
作業系統
windows XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
女 
來自
高雄 
註冊時間
2013-4-8 
最後登錄
2013-10-30 

論壇贊助勳章
1# 跳轉到 » 正序看帖
打印
tT
發表於 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

圖二.jpg (59.32 KB)

圖二.jpg

收藏 分享
learner

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1446 
主題
40 
精華
0 
積分
1470 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2024-10-21 
23#
發表於 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
用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
22#
發表於 2013-6-2 10:45 | 只看該作者
回復 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

  7.     t1 = Timer
  8.     Application.ScreenUpdating = False
  9.     '  Application.Calculation = xlCalculationManual

  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

  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 前輩提供) 測試過。
妳可以自行測測看。

TOP

sunnyso

帖子
605 
主題
92 
精華
0 
積分
648 
點名
0  
作業系統
windows 
軟體版本
7 
閱讀權限
50 
性別
男 
來自
macau 
註冊時間
2013-4-5 
最後登錄
2019-2-10 

熱烈參與勳章好學求知勳章
21#
發表於 2013-6-2 00:12 | 只看該作者
回復 20# yliu

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

TOP

yliu

帖子
49 
主題
8 
精華
0 
積分
63 
點名
0  
作業系統
windows XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
女 
來自
高雄 
註冊時間
2013-4-8 
最後登錄
2013-10-30 

論壇贊助勳章
20#
發表於 2013-6-1 23:54 | 只看該作者
回復 16# sunnyso

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

TOP

yliu

帖子
49 
主題
8 
精華
0 
積分
63 
點名
0  
作業系統
windows XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
女 
來自
高雄 
註冊時間
2013-4-8 
最後登錄
2013-10-30 

論壇贊助勳章
19#
發表於 2013-6-1 23:36 | 只看該作者
回復 14# sunnyso

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

TOP

yliu

帖子
49 
主題
8 
精華
0 
積分
63 
點名
0  
作業系統
windows XP 
軟體版本
Office 2003 
閱讀權限
20 
性別
女 
來自
高雄 
註冊時間
2013-4-8 
最後登錄
2013-10-30 

論壇贊助勳章
18#
發表於 2013-6-1 23:22 | 只看該作者
回復 15# c_c_lai

謝謝詳細說明
learner

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
17#
發表於 2013-6-1 11:09 | 只看該作者
回復 16# sunnyso
SUMIFS 的處理的確蠻簡潔的，值得研究及應用，
以往(工作)我是偏重於從事應用軟體與網頁應用方面，
從無機緣接觸過 Excel，退下後為幫助友人才開始接觸
Excel (新手)， 是故較少使用此類似之函數，
謝謝你的指教！ 它對我蠻有助益的，再次謝謝！

TOP

sunnyso

帖子
605 
主題
92 
精華
0 
積分
648 
點名
0  
作業系統
windows 
軟體版本
7 
閱讀權限
50 
性別
男 
來自
macau 
註冊時間
2013-4-5 
最後登錄
2019-2-10 

熱烈參與勳章好學求知勳章
16#
發表於 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
ss

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
15#
發表於 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() 來過濾，得值得以正確顯示，不致歸類錯誤。

TOP

        靜思自在 : 願要大、志要堅、氣要柔、心要細。
123
返回列表 上一主題