Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Brr, Crr, Z, i&, T$, 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
If Z(T) = "" Then
Z(T) = Brr(i, 3) & " █ " & Brr(i, 4)
Else
Z(T) = Z(T) & vbLf & Brr(i, 3) & " █ " & Brr(i, 4)
End If
i00: Next
Brr = Range([專案!D1], [專案!D65536].End(3))
[D:D].ClearComments
For i = 1 To UBound(Brr)
If Brr(i, 1) = "" Or Z(Brr(i, 1) & "") = "" Then GoTo i01
Cells(i, 4).AddComment
Cells(i, 4).Comment.Text Text:=Z(Brr(i, 1) & "")
Cells(i, 4).Comment.Shape.TextFrame.Characters.Font.Size = 16
Cells(i, 4).Comment.Shape.DrawingObject.AutoSize = True
i01: Next
Set Z = Nothing: Erase Brr: Set xB = Nothing: Set Sh = Nothing
End Sub作者: cowww 時間: 2023-6-26 16:12
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作者: cowww 時間: 2023-6-27 13:17
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, 1): 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([專案!Z1], [專案!Z65536].End(3))
[Z:Z].ClearComments
For i = 1 To UBound(Brr)
T1 = Brr(i, 1): If T1 = "" Or Z(T1) = "" Then GoTo i01
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
Set Z = Nothing: Erase Brr: Set xB = Nothing: Set Sh = Nothing
來源檔判斷是否開啟//
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
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作者: cowww 時間: 2023-7-10 13:15
