Board logo

標題: [發問] 用VBA來執行SUMPRODUCT多條件統計 [打印本頁]
作者: b9208    時間: 2013-4-2 14:10     標題: 用VBA來執行SUMPRODUCT多條件統計

各位前輩

原使用SUMPRODUCT多條件統計來執行六個月資料，但今日需執行二年資料，運算時間長，中途修改資料又要重新運算，等待時間長。
所以請教前輩，如何用VBA來執行SUMPRODUCT多條件統計運算。

[attach]14513[/attach]
作者: GBKEE    時間: 2013-4-2 18:05

回復 1# b9208
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim D(1 To 2) As Object, i As Integer, M As String
  4.     Dim R As Integer, C As Integer, A As Range
  5.     Set D(1) = CreateObject("scripting.dictionary")    '字典物件
  6.     Set D(2) = CreateObject("scripting.dictionary")
  7.     With Sheets("明細")
  8.         i = 6
  9.         Do While .Cells(i, "d") <> ""
  10.             M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
  11.             D(1)(M) = D(1)(M) + 1                                                               '全部
  12.             M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
  13.             D(2)(M) = D(2)(M) + 1                                                               '區域
  14.             i = i + 1
  15.         Loop
  16.     End With
  17.      With Sheets("統計")
  18.         For Each A In .Range("F3:J12,F18:J27,F33:J42,F48:J57").Areas                     '修正為你的全部 及 區域 的範圍
  19.             With A
  20.                 For R = 3 To .Rows.Count - 1
  21.                     For C = 2 To .Columns.Count
  22.                         If .Cells(1) = "全部" Then                  '全部
  23.                             .Cells(R, C) = D(1)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C))
  24.                         Else                                        '區域
  25.                              .Cells(R, C) = D(2)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C) & .Cells(1))
  26.                         End If
  27.                     Next
  28.                 Next
  29.                 For C = 2 To .Columns.Count
  30.                     .Cells(.Rows.Count, C).FormulaR1C1 = "=SUM(R[-" & .Rows.Count - 3 & "]C:R[-1]C)"  '公式
  31.                     .Cells(.Rows.Count, C) = .Cells(.Rows.Count, C).Value
  32.                 Next
  33.         
  34.             End With
  35.         Next
  36.      End With
  37. End Sub
複製代碼
作者: b9208    時間: 2013-4-2 23:58

回復 2# GBKEE
非常感謝版主回覆
下列補充說明：
1. 各輸出表格之週次及單位，由程式運算後自動代出。
2. 依B4:B13設定篩選單位，輸出篩選單位全部統計資料表。（如檔案內QWE,ASD單位）
3. 如果B18:B21有設定篩選區域，則再增加輸出該區域統計資料表。（如檔案內QWE,ASD單位之北部資料）
以上請參考附件

[attach]14523[/attach]
作者: GBKEE    時間: 2013-4-3 16:35

回復 3# b9208
試試看
  1. Option Explicit
  2. Dim D(1 To 2) As Object, 週次 As Object, 統計單位 As Variant, Ar        'Dim : 此模組的私用變數(僅此模組可用)
  3. Sub EX()
  4.     Dim i As Integer, ii As Integer, M As String, Rng As Range
  5.     'Dim Rng As Range, M As String
  6.     'Dim R As Integer, C As Integer
  7.     Set D(1) = CreateObject("scripting.dictionary")    '字典物件
  8.     Set D(2) = CreateObject("scripting.dictionary")
  9.     Set 週次 = CreateObject("scripting.dictionary")
  10.     With Sheets("統計")
  11.         i = Application.CountA(.[b4:b13])
  12.         統計單位 = Join(Application.Transpose(.Range(.[b4], .[b4].Offset(i - 1))), ",")        '統計單位=QWE,ASD
  13.     End With
  14.     With Sheets("明細")
  15.         i = 6
  16.         Do While .Cells(i, "D") <> ""
  17.             ' "," & 統計單位 & "," -> ,QWE,ASD,
  18.             If InStr("," & 統計單位 & ",", "," & .Cells(i, "F") & ",") Then   '比對到  ,QWE,   ,ASD, .....
  19.                 週次(.Cells(i, "F").Value) = 週次(.Cells(i, "F").Value) & "," & Mid(.Cells(i, "E"), 1, 4)
  20.                 M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
  21.                 D(1)(M) = D(1)(M) + 1                                                               '全部
  22.                 M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
  23.                 D(2)(M) = D(2)(M) + 1                                                               '區域
  24.             End If
  25.             i = i + 1
  26.         Loop
  27.     End With
  28.     統計單位 = Split(統計單位, ",")                                             ' QWE,ASD,ZXC 置於陣列
  29.     With Sheets("統計")
  30.         .[F:J].Clear
  31.         For i = 0 To UBound(統計單位)
  32.             Ar = Array("全部", "單位", "MON", "TUE", "WED", "THU", "FRI", "SAT", "SUN", "小計")
  33.             If i = 0 Then
  34.                 Set Rng = .[F3]
  35.             Else
  36.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '每張表格間隔五列
  37.             End If
  38.             週次(統計單位(i)) = Mid(週次(統計單位(i)), 2)
  39.             週次(統計單位(i)) = Split(週次(統計單位(i)), ",")                   '取得週次
  40.    
  41.             表格製造 Rng, i
  42.             表格統計 Rng.CurrentRegion
  43.             
  44.             For ii = 0 To Application.CountA(.Range("B18:B21")) - 1
  45.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '每張表格間隔五列
  46.                 Ar(0) = .[B18].Offset(ii)
  47.                 表格製造 Rng, i
  48.                 表格統計 Rng.CurrentRegion
  49.             Next
  50.     Next
  51. End With
  52. End Sub
  53. Private Sub 表格製造(Rng As Range, i As Integer)
  54.     Rng.Resize(UBound(Ar) + 1).Value = Application.Transpose(Ar)
  55.     With Rng.Offset(, 1).Resize(1, UBound(週次(統計單位(i))) + 1)
  56.         .Value = 週次(統計單位(i))
  57.         .Offset(1) = 統計單位(i)
  58.     End With
  59.     Rng.CurrentRegion.Borders.LineStyle = 1  '框線
  60. End Sub
  61. Private Sub 表格統計(Rng As Range)
  62.     Dim R As Integer, C As Integer
  63.     With Rng
  64.         For R = 3 To .Rows.Count - 1
  65.             For C = 2 To .Columns.Count
  66.                 If .Cells(1) = "全部" Then                  '全部
  67.                     .Cells(R, C) = D(1)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C))
  68.                 Else                                        '區域
  69.                     .Cells(R, C) = D(2)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C) & .Cells(1))
  70.                 End If
  71.             Next
  72.         Next
  73.         For C = 2 To .Columns.Count
  74.             .Cells(.Rows.Count, C).FormulaR1C1 = "=SUM(R[-" & .Rows.Count - 3 & "]C:R[-1]C)"  '公式
  75.             .Cells(.Rows.Count, C) = .Cells(.Rows.Count, C).Value
  76.         Next
  77.     End With
  78. End Sub
複製代碼
作者: b9208    時間: 2013-4-9 16:32

回復 4# GBKEE
前輩您好
VBA經執行測試後，表格位置及數據都正確，
但每週數據都重複出現多筆。
例如2012年度有1201~1251週，計51週筆，
但程式執行後確產出6000多筆週次資料。
不懂原因
非常感謝指導
作者: GBKEE    時間: 2013-4-9 18:49

回復 5# b9208
上傳檔案看看
作者: b9208    時間: 2013-4-9 21:12

回復 6# GBKEE
檔案如附件
謝謝

    [attach]14603[/attach]
作者: GBKEE    時間: 2013-4-10 15:25

回復 7# b9208
唉週次沒有弄好,更正如下
  1. Option Explicit
  2. Dim D(1 To 2) As Object, 週次 As Object, Ar '        'Dim : 此模組的私用變數(僅此模組可用)
  3. Sub EX()
  4.     Dim i As Integer, ii As Integer, M As String, Rng As Range, 統計單位 As Variant
  5.     Set D(1) = CreateObject("scripting.dictionary")    '字典物件
  6.     Set D(2) = CreateObject("scripting.dictionary")
  7.     Set 週次 = CreateObject("scripting.dictionary")
  8.     With Sheets("統計")
  9.         i = Application.CountA(.[b4:b13])
  10.         統計單位 = Join(Application.Transpose(.Range(.[b4], .[b4].Offset(i - 1))), ",")        '統計單位=QWE,ASD
  11.     End With
  12.     With Sheets("明細")
  13.         i = 6
  14.         Do While .Cells(i, "D") <> ""
  15.             ' "," & 統計單位 & "," -> ,QWE,ASD,
  16.             If InStr("," & 統計單位 & ",", "," & .Cells(i, "F") & ",") Then   '比對到  ,QWE,   ,ASD, .....
  17.                
  18.                 If InStr("," & 週次(.Cells(i, "F").Value) & ",", "," & Mid(.Cells(i, "E"), 1, 4)) & "," = 0 Then '統計單位: 比對週次不存在, .....
  19.                     週次(.Cells(i, "F").Value) = IIf(週次(.Cells(i, "F").Value) = "", "", 週次(.Cells(i, "F").Value) & ",") & Mid(.Cells(i, "E"), 1, 4)
  20.                 End If
  21.                
  22.                 M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
  23.                 D(1)(M) = D(1)(M) + 1                                                               '全部
  24.                 M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
  25.                 D(2)(M) = D(2)(M) + 1                                                               '區域
  26.             End If
  27.             i = i + 1
  28.         Loop
  29.     End With
  30.     With Sheets("統計")
  31.         .[F:IQ].Clear
  32.         For i = 0 To Application.CountA(.Range("B4:B13")) - 1
  33.             Ar = Array("全部", "單位", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun", "小計")
  34.             If i = 0 Then
  35.                 Set Rng = .[F3]
  36.             Else
  37.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '每張表格間隔五列
  38.             End If
  39.            
  40.             週次(.Range("B4").Offset(i).Value) = Split(週次(.Range("B4").Offset(i).Value), ",")
  41.             '取得統計單位之週次
  42.    
  43.             表格製造 Rng, .Range("B4").Offset(i)
  44.             表格統計 Rng.CurrentRegion
  45.             
  46.             For ii = 0 To Application.CountA(.Range("B18:B21")) - 1
  47.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '每張表格間隔五列
  48.                 Ar(0) = .[B18].Offset(ii)
  49.                 表格製造 Rng, .Range("B4").Offset(i)
  50.                 表格統計 Rng.CurrentRegion
  51.             Next
  52.     Next
  53. End With
  54. End Sub
  55. Private Sub 表格製造(Rng As Range, 單位 As String)
  56.     Rng.Resize(UBound(Ar) + 1).Value = Application.Transpose(Ar)
  57.     With Rng.Offset(, 1).Resize(1, UBound(週次(單位)) + 1)
  58.         .Value = 週次(單位)
  59.         .Offset(1) = 單位
  60.     End With
  61.     Rng.CurrentRegion.Borders.LineStyle = 1  '框線
  62. End Sub
  63. Private Sub 表格統計(Rng As Range)
  64.     Dim R As Integer, C As Integer
  65.     With Rng
  66.         For R = 3 To .Rows.Count - 1
  67.             For C = 2 To .Columns.Count
  68.                 If .Cells(1) = "全部" Then                  '全部
  69.                     .Cells(R, C) = D(1)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C))
  70.                 Else                                        '區域
  71.                     .Cells(R, C) = D(2)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C) & .Cells(1))
  72.                 End If
  73.             Next
  74.         Next
  75.         For C = 2 To .Columns.Count
  76.             .Cells(.Rows.Count, C).FormulaR1C1 = "=SUM(R[-" & .Rows.Count - 3 & "]C:R[-1]C)"  '公式
  77.             .Cells(.Rows.Count, C) = .Cells(.Rows.Count, C).Value
  78.         Next
  79.     End With
  80. End Sub
複製代碼
作者: b9208    時間: 2013-4-11 23:18

回復 8# GBKEE
GBKEE版主
非常感謝指導
執行ok
如果d欄至最後一筆資料其中有空格，則執行不完整。
今修訂增加判斷   Do While .Cells(i, "D") <> "" Or .Cells(i, "F") <> ""
執行就ok
另一修訂將Do迴圈改成For迴圈，也ok。
u = .[d65536].End(xlUp).Row
For i = 6 To u

請教於Excel 2010中判斷最後一筆資料列，應如何修改下面式子。
u = .[d65536].End(xlUp).Row
謝謝指導
作者: GBKEE    時間: 2013-4-15 19:26

回復 9# b9208
  1. Sub Ex()
  2.     Dim U As Long, E As String
  3.     Select Case Application.Version
  4.         Case "12.0"
  5.             E = 2007
  6.         Case "11.0"
  7.             E = 2003
  8.         Case "10.0"
  9.             E = 2002
  10.         Case "9.0"
  11.             E = 2000
  12.         Case "8.0"
  13.             E = 97
  14.         Case "7.0"
  15.             E = 95
  16.         Case "5.0"
  17.             E = "5.0"
  18.         Case Else
  19.             E = "未知"
  20.     End Select
  21.     With ActiveSheet
  22.       MsgBox "Excel " & E & " 版本的總列數:  " & .Rows.Count
  23.         U = .Range("d" & .Rows.Count).End(xlUp).Row
  24.     End With
  25. End Sub
複製代碼
作者: b9208    時間: 2013-4-16 23:04

回復 10# GBKEE
非常感謝超級版主的指導
感激不盡
謝謝
作者: b9208    時間: 2013-4-20 13:24

回復 8# GBKEE
Dear GBKEE
Private Sub 表格統計(Rng As Range)中
沒有資料的儲存格，目前為空格，
如果沒有資料的儲存格填入"0"，
請問如何修改
謝謝指導
作者: GBKEE    時間: 2013-4-23 14:49

回復 12# b9208
  1. Private Sub 表格統計(Rng As Range)
  2.     Dim R As Integer, C As Integer
  3.     With Rng
  4.         For R = 3 To .Rows.Count - 1
  5.             For C = 2 To .Columns.Count
  6.                 If .Cells(1) = "全部" Then                  '全部
  7.                     .Cells(R, C) = D(1)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C))
  8.                 Else                                        '區域
  9.                     .Cells(R, C) = D(2)(.Cells(R, 1) & Mid(.Cells(1, C), 1, 4) & .Cells(2, C) & .Cells(1))
  10.                 End If
  11.                 '********
  12.                 If .Cells(R, C) = "" Then .Cells(R, C) = 0   
  13.                 '********
  14.             Next
  15.         Next
  16.         For C = 2 To .Columns.Count
  17.             .Cells(.Rows.Count, C).FormulaR1C1 = "=SUM(R[-" & .Rows.Count - 3 & "]C:R[-1]C)"  '公式
  18.             .Cells(.Rows.Count, C) = .Cells(.Rows.Count, C).Value
  19.         Next
  20.     End With
  21. End Sub
複製代碼
作者: b9208    時間: 2013-4-23 21:56

回復 13# GBKEE
非常感謝指導
作者: b9208    時間: 2013-5-8 00:11

回復 8# GBKEE
Dear GBKEE
如下式子，累計次數
22.   M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
23.   D(1)(M) = D(1)(M) + 1               '全部
24.   M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
25.   D(2)(M) = D(2)(M) + 1               '區域  

如欲計算相同資料只計算一筆。如
22. M = .Cells(i, "D") & .Cells(i, "E") & .Cells(i, "F") 此三項資料相同者只計算一筆
24. M = .Cells(i, "D") & .Cells(i, "E") & .Cells(i, "F") & .Cells(i, "L")  此四項資料相同者只計算一筆

感謝指導
作者: GBKEE    時間: 2013-5-8 07:21

回復 15# b9208
所有程式碼中
Mid(.Cells(i, "E"), 1, 4)   修改為  .Cells(i, "E")
Mid(.Cells(1, C), 1, 4)    修改為  .Cells(1, C)

1.可一一自行修改
2.Vba 視窗指令 編輯->取代
作者: freeffly    時間: 2013-5-9 16:28

留個學習紀錄
用字典在某些情況速度好像不快
這個例子我大概只會想到用SQL的方式處理
作者: b9208    時間: 2013-5-9 20:35

回復 16# GBKEE
Dear GBKEE
如果依照方式修訂：
Mid(.Cells(i, "E"), 1, 4)   修改為  .Cells(i, "E")
Mid(.Cells(1, C), 1, 4)    修改為  .Cells(1, C)

那週次數字如何取得及輸出
謝謝
作者: GBKEE    時間: 2013-5-10 07:16

回復 18# b9208
那週次數字如何取得及輸出 !!!
去掉MID: 取[申請編號]完全相同,還要歸類到週次中
請上傳範例圖表看看
作者: b9208    時間: 2013-5-10 13:18

回復 19# GBKEE

上傳檔案
敬請指導
[attach]14945[/attach]
作者: GBKEE    時間: 2013-5-10 17:17

回復 20# b9208
附檔 Ex()程序不是 8# 的Ex()程序
  1. Option Explicit
  2. Dim D(1 To 3) As Object, 週次 As Object, Ar '        'Dim : 此模組的私用變數(僅此模組可用)
  3. Sub EX()
  4.     Dim i As Integer, ii As Integer, M As String, Rng As Range, 統計單位 As Variant
  5.     Set D(1) = CreateObject("scripting.dictionary")    '字典物件
  6.     Set D(2) = CreateObject("scripting.dictionary")
  7.     Set D(3) = CreateObject("scripting.dictionary")
  8.     Set 週次 = CreateObject("scripting.dictionary")
  9.     With Sheets("統計")
  10.         i = Application.CountA(.[b4:b13])
  11.         統計單位 = Join(Application.Transpose(.Range(.[b4], .[b4].Offset(i - 1))), ",")        '統計單位=QWE,ASD
  12.     End With
  13.     With Sheets("明細")
  14.         i = 6
  15.         Do While .Cells(i, "D") <> ""
  16.             ' "," & 統計單位 & "," -> ,QWE,ASD,
  17.             If InStr("," & 統計單位 & ",", "," & .Cells(i, "F") & ",") Then   '比對到  ,QWE,   ,ASD, .....
  18.                 M = .Cells(i, "D") & .Cells(i, "E") & .Cells(i, "F") & .Cells(i, "L")
  19.                 If D(3)(M) = "" Then   ' *** 這裡判斷4欄都相同為一筆資料 ****
  20.                     D(3)(M) = 0
  21.                     If InStr("," & 週次(.Cells(i, "F").Value) & ",", "," & Mid(.Cells(i, "E"), 1, 4)) & "," = 0 Then '統計單位: 比對週次不存在, .....
  22.                         週次(.Cells(i, "F").Value) = IIf(週次(.Cells(i, "F").Value) = "", "", 週次(.Cells(i, "F").Value) & ",") & Mid(.Cells(i, "E"), 1, 4)
  23.                     End If
  24.                     M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F")
  25.                     D(1)(M) = D(1)(M) + 1                                                               '全部
  26.                     M = .Cells(i, "D") & Mid(.Cells(i, "E"), 1, 4) & .Cells(i, "F") & .Cells(i, "L")
  27.                     D(2)(M) = D(2)(M) + 1                                                               '區域
  28.                 End If
  29.             End If
  30.             i = i + 1
  31.         Loop
  32.     End With
  33.     With Sheets("統計")
  34.         .[F:IQ].Clear
  35.         For i = 0 To Application.CountA(.Range("B4:B13")) - 1
  36.             Ar = Array("全部", "單位", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun", "小計")
  37.             If i = 0 Then
  38.                 Set Rng = .[F3]
  39.             Else
  40.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '每張表格間隔五列
  41.             End If
  42.            
  43.             週次(.Range("B4").Offset(i).Value) = Split(週次(.Range("B4").Offset(i).Value), ",")
  44.             '取得統計單位之週次
  45.    
  46.             表格製造 Rng, .Range("B4").Offset(i)
  47.             表格統計 Rng.CurrentRegion
  48.             
  49.             For ii = 0 To Application.CountA(.Range("B18:B21")) - 1
  50.                 Set Rng = .Cells(.Rows.Count, "F").End(xlUp).Offset(6)          '每張表格間隔五列
  51.                 Ar(0) = .[B18].Offset(ii)
  52.                 表格製造 Rng, .Range("B4").Offset(i)
  53.                 表格統計 Rng.CurrentRegion
  54.             Next
  55.     Next
  56. End With
  57. End Sub
複製代碼




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