- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-12-5
|
16#
發表於 2023-6-27 10:40
| 只看該作者
回復 15# cowww
檢查簡化了一下,學習方案如下,請前輩參考
Option Explicit
Sub TEST_1()
Application.ScreenUpdating = False
Dim Brr, Z, A, B, i&, R&, T$, T1$, PH$, FN$, xB As Workbook, Sh As Worksheet
Set Z = CreateObject("Scripting.Dictionary")
PH = ThisWorkbook.Path: FN = "異動表排序.xlsm"
On Error Resume Next
Set xB = Workbooks(FN): Set Sh = xB.Sheets("異動表排序")
Brr = Range(Sh.[E1], Sh.[A65536].End(3))
On Error GoTo 0
If xB Is Nothing Then
Set xB = Workbooks.Open(PH & "\" & FN)
Brr = Range([異動表排序!E1], [異動表排序!A65536].End(3))
xB.Close 0
End If
For i = 1 To UBound(Brr)
T = Brr(i, 2): If T = "" Then GoTo i00
T1 = Brr(i, 1): A = Z(T1)
If A = "" Then
For R = i To UBound(Brr)
If T1 <> Brr(R, 1) Then Z(T1) = A: Exit For
B = " " & Brr(R, 2) & " " & Brr(R, 3) & " " & Brr(R, 4) & " " & Brr(R, 5)
If i = R Then A = Brr(R, 1) & vbLf & B Else A = A & vbLf & B
Next
End If
If Z(T) = "" Then
Z(T) = Z(T1)
ElseIf InStr(Z(T), Z(T1)) = 0 Then
Z(T) = Z(T) & vbLf & vbLf & Z(T1)
End If
i00: Next
Brr = Range([專案!D1], [專案!D65536].End(3))
[V:V].ClearComments
For i = 1 To UBound(Brr)
T1 = Brr(i, 1): If T1 = "" Or Z(T1) = "" Then GoTo i01
With Cells(i, 22).AddComment
.Text Text:=Replace(Z(T1), " " & T1, "★" & T1)
.Shape.TextFrame.Characters.Font.Size = 16
.Shape.DrawingObject.AutoSize = True
End With
i01: Next
Set Z = Nothing: Erase Brr: Set xB = Nothing: Set Sh = Nothing
End Sub |
|
