返回列表 上一主題 發帖

[發問] 多條件統計

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
1# 跳轉到 »
發表於 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

檔案如下

W2-0822.rar (62.23 KB)
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

帖子
406 
主題
8 
精華
0 
積分
453 
點名
0  
作業系統
WINDOWS 7 
軟體版本
2007 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2015-2-7 
最後登錄
2021-7-31 
2#
發表於 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
程式是依需求寫的，需求表達不清楚
或者沒有上傳附件，愛莫能助

TOP

        靜思自在 : 為自己找藉口的人永遠不會進步。
返回列表 上一主題