- 帖子
- 1447
- 主題
- 40
- 精華
- 0
- 積分
- 1471
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2025-2-11
|
本帖最後由 Andy2483 於 2023-7-10 11:16 編輯
回復 32# 准提部林
回復 30# qaqa3296
回復 27# cowww
謝謝前輩再提供新範例
謝謝 准提部林前輩指導
謝謝 qaqa3296 一起學習,超認真的學習方案
後學也提供學習方案建議如下,請前輩參考
執行結果:
Option Explicit
Sub 機台排程_Click()
Application.ScreenUpdating = False
Dim Brr, Z, A$, B$, C%, Nm&, chk, Np, 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): On Error GoTo 0
If xB Is Nothing Then Set xB = Workbooks.Open(PH & "\" & FN): chk = 1
With xB.Sheets("異動表排序")
Brr = Range(.[G1], .[A65536].End(3)(2))
End With
If chk = 1 Then xB.Close 0
For i = 2 To UBound(Brr) - 1
If IsError(Brr(i, 1)) Or IsError(Brr(i, 2)) Or Brr(i, 4) = "" Then GoTo i00
'↑1.2欄有錯誤值 或無模具號碼 略過
T = Brr(i, 4): T1 = Brr(i, 1): A = Z(T1)
If A = "" Then
For R = i To UBound(Brr)
If IsError(Brr(R, 1)) Or IsError(Brr(R, 2)) Or Brr(R, 4) = "" Then GoTo R00
'↑1.2欄有錯誤值 或無模具號碼 略過
If T1 <> Brr(R, 1) Then Exit For
For C = 4 To 7: B = B & " " & Brr(R, C): Next:
B = Brr(R, 3) & " " & B
If i = R Then A = Brr(R, 1) & vbLf & B Else A = A & vbLf & B
Z(T1) = A: B = ""
R00: 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([專案!Z1], [專案!D65536].End(3))
[Z:Z].ClearComments: [Z:Z].Interior.ColorIndex = xlNone
For i = 1 To UBound(Brr)
T1 = Brr(i, 1)
If Z(T1) = "" And Z(Brr(i, 23)) <> "" Then
Cells(i, 26).Interior.ColorIndex = 38
Np = Np + 1: GoTo i01
End If
If T1 = "" Or Z(T1) = "" Then GoTo i01
If Cells(i, 26) = "" Then
Nm = Nm + 1
Cells(i, 26).Interior.ColorIndex = 6
End If
With Cells(i, 26).AddComment
.Text Text:=Replace(Z(T1), " " & T1, "_★_" & T1)
.Shape.TextFrame.Characters.Font.Size = 16
.Shape.DrawingObject.AutoSize = True
End With
i01: Next
If Nm + Np > 0 Then
MsgBox "有排程 無標示機台: " & Nm & " 個" & vbLf & vbLf & _
"有標示機台 無排程: " & Np & " 個"
End If
Set Z = Nothing: Erase Brr: Set xB = Nothing: Set Sh = Nothing
End Sub |
|
發表於 2023-7-8 09:14
| 
