Andy2483

回復 7# cowww


    是這種樣式嗎?

下載 (242.39 KB)

2023-6-27 09:41

cowww

回復 10# Andy2483

非常感謝Andy2483大大的解惑

我試出來了
長官的要求目前有遇到報表跟異動表內容的表示內容不同
無法做為Key的問題

cowww

回復 11# Andy2483

非常感謝Andy2483大大的解惑

這看起來像長管想要的

Andy2483

回復 13# cowww


   
加個星號

下載 (249.82 KB)

2023-6-27 09:54

下載 (278.49 KB)

2023-6-27 09:59

cowww

回復 14# Andy2483

水喔
Andy2483大大真是厲害

Andy2483

回復 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

cowww

回復 16# Andy2483

非常感謝Andy2483大大的解惑

cowww

回復 16# Andy2483

請求Andy2483大大的解惑
"★"消失了，請問我改的語法哪裡出錯了?

下載 (17.53 KB)

2023-7-4 14:47

Option Explicit
Sub 按鈕22_Click()

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


End Sub

qaqa3296

回復 18# cowww

大家一起學習，我在想

Brr = Range([專案!Z1], [專案!Z65536].End(3))

這個是比對"Tool No."，有相同才加星

所以是
Brr = Range([專案!E1], [專案!E65536].End(3))

另外我想問Andy2483大大

"異動表排序"會少最後一筆資料，該如何修正，我看迴圈都有跑滿，但是會少最後一筆(沒有任何備註)，程度不夠無法修正此問題

Andy2483

回復 18# cowww


    謝謝前輩回復
查看了示意圖已經與原範例需求結果不同,請上傳新範例

不同處:

下載 (40.11 KB)

2023-7-5 07:38