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

標題: [發問] 多條件統計 [打印本頁]

作者: b9208 時間: 2020-8-20 16:13 標題: 多條件統計

您好！
請問多條件統計次數
由「資料」工作表統計每日（B欄）各人口（H欄）使用次數，並輸出於「工作表2」。
謝謝
[attach]32420[/attach]

作者: jcchiang 時間: 2020-8-21 08:20

回復 1# b9208

C7=COUNTIFS(資料!$B:$B,工作表2!$B$7,資料!$H:$H,工作表2!C6)右拉
C8=COUNTIFS(資料!$B:$B,工作表2!$B$8,資料!$H:$H,工作表2!C6)右拉

作者: b9208 時間: 2020-8-21 09:43

回復 2# jcchiang
非常感謝指導
但需統計至少一年以上資料，如用EXCEL函數方法，運算時間太久。
所以請教利用VBA方式運算

作者: 准提部林 時間: 2020-8-21 10:09

第6行的 N1~N4, S1~S5 是固定不變的???

作者: b9208 時間: 2020-8-21 11:12

回復 4# 准提部林
固定不變
謝謝

作者: jcchiang 時間: 2020-8-21 11:26

回復 3# b9208

試試看
Sub ex()
Dim arr
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
arr = Sheets("資料").[B5].CurrentRegion
For i = 2 To UBound(arr)
If Not d.Exists(arr(i, 2) & arr(i, 8)) Then
   d.Add (arr(i, 2) & arr(i, 8)), 1
Else
   d(arr(i, 2) & arr(i, 8)) = d(arr(i, 2) & arr(i, 8)) + 1
End If
Next
With Sheets(1)
arr = .[B6].CurrentRegion
For i = 2 To UBound(arr, 2) - 1
For j = 2 To UBound(arr)
   If d(arr(j, 1) & arr(1, i)) = "" Then
      arr(j, i) = 0
   Else
      arr(j, i) = d(arr(j, 1) & arr(1, i))
   End If
Next
Next
.[B6].CurrentRegion = arr
.[L7].Resize(UBound(arr) - 1) = "=sum(c7:K7)"
.[L:L] = .[L:L].Value
End With
Set d = Nothing
End Sub

作者: b9208 時間: 2020-8-21 12:31

回復 6# jcchiang
非常感謝協助與指導
程式執行OK
但「工作表2」之日期，是依據「資料」內日期輸出不重復日期，並非事先輸入的。

作者: 准提部林 時間: 2020-8-21 12:48

Sub TEST()
Dim Arr, Brr, xD, i&, j%, K, R&, C&, N&
Set xD = CreateObject("Scripting.Dictionary")
[工作表2!B7:B2000].EntireRow.Delete
Arr = [工作表2!B6:K6]
For j = 2 To UBound(Arr, 2): xD(Arr(1, j)) = j: Next
Arr = Range([資料!A1], Sheets("資料").UsedRange)
ReDim Brr(1 To UBound(Arr), 1 To 11)
For i = 5 To UBound(Arr)
K = Arr(i, 2): R = Val(xD(K)): C = Val(xD(Arr(i, 8)))
If K = "" Or C = 0 Then GoTo 101
If R = 0 Then N = N + 1: R = N: xD(K) = N: Brr(N, 1) = K
Brr(R, C) = Brr(R, C) + 1: Brr(R, 11) = Brr(R, 11) + 1
101: Next i
With [工作表2!B7].Resize(N, 11)
.Value = Brr
.Borders.LineStyle = 1
End With
End Sub

[attach]32424[/attach]

=====================

作者: b9208 時間: 2020-8-21 19:25

回復 8# 准提部林

程式執行OK
符合期望
非常感謝您

作者: b9208 時間: 2020-8-21 21:07

回復 8# 准提部林
版主您好
參考版主之程式碼，於另工作表(Outq) 統計出口是OK的。
嚐試於工作表2同時輸出入口及出口統計表，程式執行錯誤，懇請版主指導。
非常感謝
[attach]32426[/attach]

作者: n7822123 時間: 2020-8-22 01:12

回復 10# b9208

嚐試於工作表2同時輸出入口及出口統計表，程式執行錯誤

因為工作表 Outq 的表格左上還是[B6] 跟工作表2 入口表格一致

但是工作表2  出口表格左上變成 [P6] ，準大的程式要再修改位置才能正常執行

不過出口入口程式邏輯一樣，只有抓的位置與輸出的位置不同，我覺得沒必要改2段程式

出口、入口可以合併寫，我也自己寫了一段，並加大彈性

N1~N4, S1~S5 順序隨便給也沒關係，都可以找的到對應，可以參考看看

程式如下

Sub 統計入口()
[B6].CurrentRegion.Offset(2).Clear
統計 [B6], 8
End Sub
Sub 統計出口()
[P6].CurrentRegion.Offset(2).Clear
統計 [P6], 9
End Sub
Sub 統計(ByVal cel0 As Range, Ci As Long)
Dim D, Arr, Brr, T$, K1$, K2$, Key, R&, Ro&, Co&, Rg As Range
Set D = CreateObject("Scripting.Dictionary")
Arr = [資料!A4].CurrentRegion
For R = 2 To UBound(Arr)
  K1 = Arr(R, 2): K2 = Arr(R, Ci)
  If K1 <> T Then Ro = Ro + 1: D(K1) = Ro: T = K1
  If K2 <> "" Then Key = K1 & "-" & K2: D(Key) = D(Key) + 1
Next
ReDim Brr(1 To Ro, 1 To 11)
For Each Key In D.keys
  If InStr(Key, "-") = 0 Then Brr(D(Key), 1) = Key: GoTo 下個Key
  Ro = D(Split(Key, "-")(0))
  Set Rg = cel0.Resize(, 10).Find(Split(Key, "-")(1), , , xlWhole)
  If Not Rg Is Nothing Then
Co = Rg.Column - cel0.Column + 1
Brr(Ro, Co) = D(Key): Brr(Ro, 11) = Brr(Ro, 11) + D(Key)
  End If
下個Key: Next
With cel0(2).Resize(Ro, 11)
  .Value = Brr: .Borders.LineStyle = 1
  .VerticalAlignment = xlBottom
  .HorizontalAlignment = xlCenter
End With
End Sub

檔案如下

[attach]32428[/attach]

作者: 准提部林 時間: 2020-8-22 09:15

回復 10# b9208

Sub TEST_T()
Dim Arr, Brr, Crr, xD, i&, K, R&, C&, N1&, N2&
Set xD = CreateObject("Scripting.Dictionary")
[工作表2!B7:B2000].EntireRow.Delete
Arr = [工作表2!B6:K6]
For i = 2 To UBound(Arr, 2): xD(Arr(1, i)) = i: Next
Arr = Range([資料!A1], Sheets("資料").UsedRange)
ReDim Brr(1 To UBound(Arr), 1 To 11):  Crr = Brr
For i = 5 To UBound(Arr)
K = Arr(i, 2): If K = "" Then GoTo 101
R = Val(xD(K)): C = Val(xD(Arr(i, 8)))
If C > 0 Then
   If R = 0 Then N1 = N1 + 1: R = N1: xD(K) = R: Brr(R, 1) = K
   Brr(R, C) = Brr(R, C) + 1: Brr(R, 11) = Brr(R, 11) + 1
End If
'--------------------------------
R = Val(xD(K & "/")): C = Val(xD(Arr(i, 9)))
If C > 0 Then
   If R = 0 Then N2 = N2 + 1: R = N2: xD(K & "/") = R: Crr(R, 1) = K
   Crr(R, C) = Crr(R, C) + 1: Crr(R, 11) = Crr(R, 11) + 1
End If
101: Next i
With [工作表2!B7].Resize(N1, 11)
   .Value = Brr
   .Borders.LineStyle = 1
End With
With [工作表2!P7].Resize(N2, 11)
   .Value = Crr
   .Borders.LineStyle = 1
End With
End Sub

分開寫較好解讀~~

==============================

作者: b9208 時間: 2020-8-22 09:34

回復 11# n7822123
龍大
非常感謝
執行ok

作者: b9208 時間: 2020-8-22 09:40

回復 12# 准提部林
准大
非常感謝
分開寫比較清楚及容易閱讀

作者: 准提部林 時間: 2020-8-22 10:49

Sub TEST_T2()
Dim Arr, Brr, xD, i&, j%, K, R&, C&, N&(1)
Set xD = CreateObject("Scripting.Dictionary")
[工作表2!B7:B2000].EntireRow.Delete
Arr = [工作表2!B6:K6]
For i = 2 To UBound(Arr, 2): xD(Arr(1, i) & "") = i: Next
Arr = Range([資料!A1], Sheets("資料").UsedRange)
ReDim Brr(1 To UBound(Arr), 1 To 11):  xD(0) = Brr:  xD(1) = Brr
For i = 5 To UBound(Arr)
K = Arr(i, 2): If K = "" Then GoTo i01
For j = 0 To 1
      R = xD(K & j): C = xD(Arr(i, 8 + j) & ""): Brr = xD(j)
      If C = 0 Then GoTo j01
      If R = 0 Then N(j) = N(j) + 1: R = N(j): xD(K & j) = R: Brr(R, 1) = K
      Brr(R, C) = Brr(R, C) + 1: Brr(R, 11) = Brr(R, 11) + 1
      xD(j) = Brr
j01: Next j
i01: Next i
For j = 0 To 1
With Sheets("工作表2").Range(Array("B7", "P7")(j)).Resize(N(j), 11)
      .Value = xD(j)
      .Borders.LineStyle = 1
End With
Next j
End Sub

做個小迴圈, 有點繞~~

=======================================

作者: b9208 時間: 2020-8-23 12:45

回復 11# n7822123
龍大
「資料」工作表B2, B3儲存格如果非空格，則輸出時，會在標題下增加二行。（如附件）
[attach]32453[/attach]

作者: n7822123 時間: 2020-8-23 13:35

本帖最後由 n7822123 於 2020-8-23 13:47 編輯

回復 16# b9208 '

因為這是Ctrl+A (CurrentRegion)的效果......原來第3列不一定會是空白阿

修改Arr抓取資料範圍就可以了

程式如下

Sub 統計入口()
[B6].CurrentRegion.Offset(2).Clear
統計 [B6], 8
End Sub
Sub 統計出口()
[P6].CurrentRegion.Offset(2).Clear
統計 [P6], 9
End Sub
Sub 統計(ByVal cel0 As Range, Ci As Long)
Dim D, Arr, Brr, T$, K1$, K2$, Key, R&, Ro&, Co&, Rg As Range
Set D = CreateObject("Scripting.Dictionary")
Arr = [資料!A4].Resize([資料!B4].End(4).Row - 3, 9)
For R = 2 To UBound(Arr)
  K1 = Arr(R, 2): K2 = Arr(R, Ci)
  If K1 <> T Then Ro = Ro + 1: D(K1) = Ro: T = K1
  If K2 <> "" Then Key = K1 & "-" & K2: D(Key) = D(Key) + 1
Next
ReDim Brr(1 To Ro, 1 To 11)
For Each Key In D.keys
  If InStr(Key, "-") = 0 Then Brr(D(Key), 1) = Key: GoTo 下個Key
  Ro = D(Split(Key, "-")(0))
  Set Rg = cel0.Resize(, 10).Find(Split(Key, "-")(1), , , xlWhole)
  If Not Rg Is Nothing Then
Co = Rg.Column - cel0.Column + 1
Brr(Ro, Co) = D(Key): Brr(Ro, 11) = Brr(Ro, 11) + D(Key)
  End If
下個Key: Next
With cel0(2).Resize(Ro, 11)
  .Value = Brr: .Borders.LineStyle = 1
  .VerticalAlignment = xlBottom
  .HorizontalAlignment = xlCenter
End With
End Sub

作者: b9208 時間: 2020-8-24 20:22

回復 17# n7822123
龍大
非常抱歉，輸出部分再增加「星期」欄位（如附件）。
有試這自己修訂，但是沒有成功，功力不足。
謝謝
[attach]32465[/attach]

作者: b9208 時間: 2020-8-25 21:33

回復 15# 准提部林
准大
懇請協助於工作表2內增加輸出「星期」欄位，非常感謝。
[attach]32466[/attach]

作者: 准提部林 時間: 2020-8-26 11:07

本帖最後由准提部林於 2020-8-26 12:42 編輯

回復 19# b9208

加了註解, 慢慢看:
[attach]32470[/attach]

因考慮[入口/出口]的日期資料可能不一致,
例如:7/1..入口有資料, 出口沒資料, 那兩表的列數就不相同,
所以還是兩表分別判斷~~

作者: Andy2483 時間: 2023-12-4 15:55

本帖最後由 Andy2483 於 2023-12-4 16:28 編輯

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列.字典與橫向縱向排序...,學習方案如下,請各位前輩指教
資料表:
[attach]37104[/attach]

結果表執行前:
[attach]37105[/attach]

執行後的結果表:
[attach]37106[/attach]

Option Explicit
Sub TEST_A()
Dim Brr, Crr(2000, 100), v, Z, Q, i&, j%, R&, C%, N&, U%, T2$, T8$
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range(Sheet2.[H1], Sheet2.[B65536].End(3)(1, 0))
For i = 5 To UBound(Brr)
T2 = Trim(Brr(i, 2)): T8 = Trim(Brr(i, 8))
If T2 = "" Or T8 = "" Then GoTo i01
R = Z(T2): C = Z(T8): Crr(0, 0) = "日期"
If R = 0 Then N = N + 1: R = N: Z(T2) = R: Crr(R, 0) = T2
If C = 0 Then U = U + 1: C = U: Z(T8) = C: Crr(0, C) = T8
Crr(R, C) = Crr(R, C) + 1
i01: Next
Sheet1.[B6:B2000].EntireRow.Delete
With Sheet1.[B6].Resize(N + 1, U + 2)
.Value = Crr
.Offset(0, 1).Sort KEY1:=.Item(1, 2), Order1:=1, Header:=0, Orientation:=2
.Offset(1, 0).Sort KEY1:=.Item(2, 1), Order1:=1, Header:=0, Orientation:=1
.Item(1)(2, U + 2).Resize(N, 1) = "=SUM(" & Range(.Cells(2, 2), .Cells(2, U + 1)).Address(0, 0) & ")"
.Cells(1, U + 2) = "Total"
.Borders.LineStyle = 1
End With
End Sub

作者: singo1232001 時間: 2023-12-8 15:36

Sub t5()
i = Split("Provider=Microsoft.,Jet.OLEDB.4,.0;Extended Properties=Excel ,8,.0;Data Source=", ",")
If Application.Version > 12 Then i(1) = "ACE.OLEDB.12": i(3) = 12
Set cn = CreateObject("adodb.connection"): cn.Open Join(i, "") & ThisWorkbook.FullName
Set S1 = Sheet1: Set s2 = Sheet2: S1.[B7:AA9999].ClearContents:
f = " from [資料$B4:I] "
S1.[B7].CopyFromRecordset cn.Execute("select distinct 日期,星期 " & f)
S1.[P7].CopyFromRecordset cn.Execute("select distinct 日期,星期 " & f)
p = Split("select b.c from [工作表2$B6:B] as a left join (;;) as b on a.日期=b.日期 ", ";")
For Each Z In S1.[d6:L6]
p(1) = "select 日期,星期,count(入口) as c " & f & " where 入口 = '" & Z.Value & "' group by 日期,星期,入口"
Z.Offset(1, 0).CopyFromRecordset cn.Execute(Join(p, ""))
x = x & "+ iif(IsNull(" & Z.Value & "),0," & Z.Value & ") "
Next
S1.[M7].CopyFromRecordset cn.Execute("select " & Mid(x, 2, 9999) & " from [工作表2$D6:L]")
For Each Z In S1.[R6:Z6]
p(1) = "select 日期,星期,count(出口) as c " & f & " where 出口 = '" & Z.Value & "' group by 日期,星期,出口"
Z.Offset(1, 0).CopyFromRecordset cn.Execute(Join(p, ""))
Next
S1.[AA7].CopyFromRecordset cn.Execute("select " & Mid(x, 2, 9999) & " from [工作表2$R6:Z]")
End Sub

複製代碼

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