多條件統計 - Excel程式區 - 麻辣家族討論版版

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

12^#

發表於 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

分開寫較好解讀~~

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

帖子: 182
主題: 34
精華: 0
積分: 316
點名: 0
作業系統: Win 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: Taiwan
註冊時間: 2010-5-2
最後登錄: 2023-6-24

13^#

發表於 2020-8-22 09:34 | 只看該作者

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

100 字節以內
不支持自定義 Discuz! 代碼

帖子: 182
主題: 34
精華: 0
積分: 316
點名: 0
作業系統: Win 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: Taiwan
註冊時間: 2010-5-2
最後登錄: 2023-6-24

14^#

發表於 2020-8-22 09:40 | 只看該作者

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

100 字節以內
不支持自定義 Discuz! 代碼

版主 Rank: 7 Rank: 7 Rank: 7

准提部林

帖子: 2834
主題: 10
精華: 0
積分: 2890
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-23

15^#

發表於 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

做個小迴圈, 有點繞~~

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

帖子: 182
主題: 34
精華: 0
積分: 316
點名: 0
作業系統: Win 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: Taiwan
註冊時間: 2010-5-2
最後登錄: 2023-6-24

16^#

發表於 2020-8-23 12:45 | 只看該作者

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

W2-0823.rar (28.66 KB)

100 字節以內
不支持自定義 Discuz! 代碼

n7822123

　暱稱: 阿龍

帖子: 406
主題: 8
精華: 0
積分: 453
點名: 0
作業系統: WINDOWS 7
軟體版本: 2007
閱讀權限: 20
性別: 男
來自: 台灣
註冊時間: 2015-2-7
最後登錄: 2021-7-31

17^#

發表於 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

程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助