- 帖子
- 2848
- 主題
- 10
- 精華
- 0
- 積分
- 2903
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2026-7-25
|
回復 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
分開寫較好解讀~~
============================== |
|
發表於 2020-8-21 10:09
| 
