123
返回列表 上一主題 發帖

[發問] 2個條件的加總

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

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

Andy2483
　暱稱: 厚臉皮的學生

大學生Rank: 4

帖子
1447 
主題
40 
精華
0 
積分
1471 
點名
0  
作業系統
Windows 7 
軟體版本
Excel 2010 & 2016 
閱讀權限
50 
性別
男 
來自
台灣 
註冊時間
2020-7-15 
最後登錄
2025-5-5 
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

        靜思自在 : 靜坐常恩己過、閒談莫論人非。
123
返回列表 上一主題