- 帖子
- 1425
- 主題
- 40
- 精華
- 0
- 積分
- 1449
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-4-16
|
謝謝論壇,謝謝各位前輩
後學藉此帖修訂方案複習註解如下,請各位前輩指教
Option Explicit
Sub Total()
Dim Arr, Brr, Crr, Z, i&, N&, R&, s%, T$, A$, xR As Range, xT As Range
'↑宣告變數:&是長整數,%是短整數,沒有指定的是通用型變數
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
With Sheets("Total").UsedRange
.Offset(2).EntireRow.Delete
.Offset(, 5).EntireColumn.Delete
Set xT = .Item(1).Resize(2, 5): Set xR = .Item(3, 1): A = [KP!C1]
End With '此段是留下一個標題儲存格,其餘舊資料欄/列刪除
For s = 1 To 4
'↑設順迴圈!令s變數從1 到4
Brr = Sheets(s).[A1].CurrentRegion: ReDim Crr(1 To UBound(Brr), 1 To 5)
'↑令Brr變數是寫入區域儲存格值的二維陣列,宣告Crr變數是二維空陣列
For i = 2 To UBound(Brr)
'↑設順迴圈!令i變數從2 到Brr陣列縱向最大索引列號
If Brr(i, 1) <> T And Brr(i, 1) <> "" Then T = Brr(i, 1)
If Not IsNumeric(T) Or Brr(i, 13) = "" Then GoTo i01 Else R = Z(T)
If R = 0 Then N = N + 1: R = N: Crr(R, 1) = T: Crr(R, 2) = Brr(i, 13): Z(T) = N
If InStr("/" & Crr(R, 2) & "/", "/" & Brr(i, 13) & "/") = 0 Then Crr(R, 2) = Crr(R, 2) & "/" & Brr(i, 13)
If Brr(i, 15) <> "" Then Crr(R, 4) = "KP"
If Brr(i, 14) <> "" Or (Brr(i, 14) = "" And Brr(i, 15) = "") Then Crr(R, 3) = "KH"
If Brr(i, 14) = A Or Brr(i, 15) = A Then Crr(R, 5) = A
If Brr(i, 14) = "" And Brr(i, 15) = "" And Crr(R, 5) <> A Then Crr(R, 5) = "-"
i01: Next '此段是依條件將結果寫入Crr陣列中
xT.Copy xR(-1): xR(-1) = "No." & Sheets(s).Name
'↑令標題儲存格複製到目標格,令標題格寫入工作表名
With xR.Resize(N, 5)
.Value = Crr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Columns(3).Font.ColorIndex = 3
.Columns(4).Font.ColorIndex = 5
.Font.Bold = True
End With '此段是令擴展適量儲存格範圍以Crr陣列值寫入,並調整該範圍格式
N = 0: Z.RemoveAll: Set xR = xR(1, 7)
'↑令N變數歸零,Z字典清空,令xR變數右移到自身開始的第7格
Next
End Sub |
|
發表於 2024-3-11 10:41
| 
