- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
6#
發表於 2023-6-27 08:00
| 只看該作者
謝謝論壇,謝謝各位前輩
後學藉此帖複習昨天的學習方案,方案學習心得註解如下,請各位前輩指教
Option Explicit
Sub TEST()
Application.ScreenUpdating = False
'↑令螢幕暫不隨著程序做變化
Dim Brr, Z, i&, T$, PH$, FN$, xB As Workbook, Sh As Worksheet
'↑宣告變數($是字串變數,&是長整數,沒有符號的是通用型變數)
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
PH = ThisWorkbook.Path: FN = "異動表排序.xlsm"
'↑令PH變數是 本檔資料夾位址,令FN變數是 指定檔名(資料表)
On Error Resume Next
'↑令程序暫遇到錯誤就繼續執行下個程序,不要停下來排錯
Set xB = Workbooks(FN): Set Sh = xB.Sheets("異動表排序")
'↑令xB變數是 活頁簿("異動表排序.xlsm"),令Sh變數是其工作表
Brr = Range(Sh.[E1], Sh.[A65536].End(3))
'↑令Brr變數是 二維陣列,以A~E欄儲存格值帶入陣列中
On Error GoTo 0
'↑令程序恢復遇到錯誤就停下來排錯
'這段不排錯的程序是為了 "異動表排序.xlsm"被開啟的情境下,
'讓Brr可以裝進陣列值
'如果檔案沒有被開啟的情況,程序就會跳過這些程序,繼續下行
If xB Is Nothing Then
'↑如果xB變數還沒有裝入活頁簿("異動表排序.xlsm")??
Set xB = Workbooks.Open(PH & "\" & FN)
'↑令開啟指定路徑下的檔案,並令xB變數是此活頁簿
Brr = Range([異動表排序!E1], [異動表排序!A65536].End(3))
'↑令Brr變數是 二維陣列,以A~E欄儲存格值帶入陣列中
xB.Close 0
'↑令活頁簿不存檔關閉
End If
For i = 1 To UBound(Brr)
'↑設順迴圈
T = Brr(i, 2): If T = "" Then GoTo i00
'↑令T變數是 迴圈列第2欄Brr陣列值,如果T變數是空的!
'是就跳到標示i00位置繼續執行
If Z(T) = "" Then
'↑如果以T變數查Z字典得item值是空字元?
Z(T) = Brr(i, 3) & " █ " & Brr(i, 4)
'↑是就令在Z字典裡的T變數key 的item換成新字串
'新字串:迴圈列第3欄Brr陣列值連接 " █ "再連接 迴圈列第4欄Brr陣列值,
'成為新字串,放回Z字典裡
Else
Z(T) = Z(T) & vbLf & Brr(i, 3) & " █ " & Brr(i, 4)
'↑否則(T變數key 的item值已經有字串!)
'令item連接換行再連接 迴圈列第3欄Brr陣列值連接 " █ "再連接
'迴圈列第4欄Brr陣列值成為新字串,放回Z字典裡
End If
i00: Next
Brr = Range([專案!D1], [專案!D65536].End(3))
'↑令Brr變數換裝結果表的D欄儲存格值,依然是 二維陣列
'PS:Brr宣告是通用型變數,可以任意=換裝資料 或Set Brr = 物件
[D:D].ClearComments
'↑令D欄的註解清除
For i = 1 To UBound(Brr)
'↑設順迴圈
If Brr(i, 1) = "" Or Z(Brr(i, 1) & "") = "" Then GoTo i01
'↑排除空格或字典裡item是空字元的項目,跳到標示i01位置繼續執行
Cells(i, 4).AddComment
'↑令i迴圈數列D欄儲存格插入註解
Cells(i, 4).Comment.Text Text:=Z(Brr(i, 1) & "")
'↑令i迴圈數列D欄儲存格的註解文字是 迴圈Brr陣列值查Z字典得item值
Cells(i, 4).Comment.Shape.TextFrame.Characters.Font.Size = 16
'↑令i迴圈數列D欄儲存格的註解文字大小為 16
Cells(i, 4).Comment.Shape.DrawingObject.AutoSize = True
'↑令i迴圈數列D欄儲存格的註解框自動縮放
i01: Next
Set Z = Nothing: Erase Brr: Set xB = Nothing: Set Sh = Nothing
'↑令釋放變數
End Sub |
|
