123
返回列表 上一主題 發帖

[發問] 多條件統計

b9208

帖子
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! 代碼

TOP

准提部林

帖子
2808 
主題
10 
精華
0 
積分
2864 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-8 
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

分開寫較好解讀~~


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

TOP

n7822123
　暱稱: 阿龍

中學生Rank: 2

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

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
10#
發表於 2020-8-21 21:07 | 只看該作者
回復 8# 准提部林
版主 您好
參考版主之程式碼，於另工作表(Outq) 統計出口是OK的。
嚐試於工作表2同時輸出入口及出口統計表，程式執行錯誤，懇請版主指導。
非常感謝
W2.rar (65.42 KB)
100 字節以內
不支持自定義 Discuz! 代碼

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
9#
發表於 2020-8-21 19:25 | 只看該作者
回復 8# 准提部林

程式執行OK
符合期望
非常感謝您
100 字節以內
不支持自定義 Discuz! 代碼

TOP

准提部林

帖子
2808 
主題
10 
精華
0 
積分
2864 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-8 
8#
發表於 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

Xl0000221.rar (21.58 KB)


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

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
7#
發表於 2020-8-21 12:31 | 只看該作者
回復 6# jcchiang
非常感謝協助與指導
程式執行OK
但「工作表2」之日期，是依據「資料」內日期輸出不重復日期，並非事先輸入的。
100 字節以內
不支持自定義 Discuz! 代碼

TOP

jcchiang

帖子
234 
主題
19 
精華
0 
積分
276 
點名
0  
作業系統
Windows XP 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
註冊時間
2013-1-7 
最後登錄
2021-10-7 
6#
發表於 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

TOP

b9208

帖子
182 
主題
34 
精華
0 
積分
316 
點名
0  
作業系統
Win 7 
軟體版本
Office 2010 
閱讀權限
20 
性別
男 
來自
Taiwan 
註冊時間
2010-5-2 
最後登錄
2023-6-24 
5#
發表於 2020-8-21 11:12 | 只看該作者
回復 4# 准提部林
固定不變
謝謝
100 字節以內
不支持自定義 Discuz! 代碼

TOP

准提部林

帖子
2808 
主題
10 
精華
0 
積分
2864 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-5-8 
4#
發表於 2020-8-21 10:09 | 只看該作者
第6行的 N1~N4, S1~S5 是固定不變的???

TOP

        靜思自在 : 不要隨心所欲，要隨心教育自己。
123
返回列表 上一主題