给单元格添加注释

quqiyuan

奋斗000 发表于 2024-5-19 20:44
结果非常好，能让另一段重复值高亮代码和它共存，同运行吗

quqiyuan

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2.     If Target.Cells.Count = 1 Then
   
3.     If Target.Value <> "" Then
   
4.         Me.UsedRange.ClearComments
   
5.         Dim selectedValue As String
   
6.         selectedValue = Target.Value
   
7.         Set sht = ThisWorkbook.Sheets("锟斤拷锟斤拷锟斤拷息锟斤拷锟斤拷")
   
8.         arr = sht.UsedRange
   
9.         r = UBound(arr)
   
10.         rr = sht.Cells(Rows.Count, "h").End(3).Row
    
11.         brr = sht.Range(sht.[h1], sht.Cells(rr, "i"))
    
12.         crr = sht.Range(sht.[c1], sht.Cells(r, "c"))
    
13.         j = Application.Match(selectedValue, crr, 0)
    
14.         If IsError(j) Then Exit Sub
    
15.         If arr(j, 5) <> "" Then
    
16.             For i = 1 To Len(arr(j, 5))
    
17.                 m = Val(Mid(arr(j, 5), i, 1))
    
18.                 s = s & "锟斤拷" & Application.VLookup(m, brr, 2, 0)
    
19.             Next
    
20.         End If
    
21.         If arr(j, 6) <> "" Then
    
22.             For i = 1 To Len(arr(j, 6))
    
23.                 m = Val(Mid(arr(j, 6), i, 1))
    
24.                 ss = ss & "锟斤拷" & Application.VLookup(m, brr, 2, 0)
    
25.             Next
    
26.         End If
    
27.         If s <> "" Then s = "锟截监考锟斤拷目: " & Right(s, Len(s) - 1) & vbCrLf
    
28.         If ss <> "" Then ss = "锟斤拷锟截监考锟斤拷目: " & Right(ss, Len(ss) - 1)
    
29.         With Target
    
30. '            If Not .Comment Is Nothing Then .Comment.Delete
    
31.             .AddComment Text:="锟洁考锟斤拷锟斤拷: " & arr(j, 4) & vbCrLf & s & ss
    
32.             .Comment.Visible = True
    
33.             .Comment.Shape.TextFrame.AutoSize = True
    
34.         End With
    
35.         Me.UsedRange.Cells.Interior.ColorIndex = xlNone
    
36.         Dim cel As Range
    
37.         For Each cel In Me.UsedRange
    
38.             If cel.Value = selectedValue Then
    
39.                 cel.Interior.Color = RGB(0, 255, 0)
    
40.             End If
    
41.         Next cel
    
42.     End If
    
43.     End If
    
44. End Sub
    

复制代码

奋斗000

feilanga 发表于 2024-5-19 18:06
输出结果加个顿号连接

精益求精。显示更加美观。再次表示感谢，不知大神是否有兴趣再挑战更难一点的要求，具体见附件。不管怎样，再次感谢。谢谢！谢谢！谢谢

奋斗000

quqiyuan 发表于 2024-5-19 21:35

非常感谢大神的帮助。不知大神是否有兴趣继续帮助完善更复杂点的要求，具体见附件。再次表示大神的帮助。谢谢