求大神指教宏如何自动匹配批注？

小杰Kimi

第一行除外，其余空格自动匹配批注。
数据源表和批注表，对号入座成Sheet1表的样式，有批注就自动添加为批注，没有批注为空白。

suntao2000

Sub 将单元格内容转到批注()
    Dim ra1 As Range, ra2 As Range, ra3 As Range, ran As Range, a$
    On Error Resume Next
    Set ra1 = Sheet1.UsedRange
    Set ra2 = Sheet2.UsedRange
    Set ra3 = Sheet3.UsedRange
    ra1.ClearContents
    ra1.ClearComments
    Sheet1.[a1].Resize(ra2.Rows.Count, ra2.Columns.Count) = ra2.Value
    Application.ScreenUpdating = False
    For Each ran In ra3
        If ran.Value <> "" And ran.Row > 1 Then
        a = ran.Formula
        With ra1(ran.Row, ran.Column)
        .AddComment
        .Comment.Text "" & a & ""
        .Comment.Visible = False
        .Comment.Shape.Fill.Visible = msoFalse
        End With
        End If
    Next
    Set ran = Nothing: ra = Nothing
    Application.ScreenUpdating = True
End Sub

小杰Kimi

suntao2000 发表于 2023-3-4 15:06
Sub 将单元格内容转到批注()
    Dim ra1 As Range, ra2 As Range, ra3 As Range, ran As Range, a$
     ...

大神请问一下，如果我希望批注的格式不变，应该加什么代码？ 格式一般 如90% 和 1.12
例如 90% 批注目前是0.09 能不能根据格式不变 显示90%

lihaosh

小杰Kimi 发表于 2023-4-12 20:15
大神请问一下，如果我希望批注的格式不变，应该加什么代码？ 格式一般 如90% 和 1.12
例如 90% 批注目 ...

1. Sub 将单元格内容转到批注()
   
2.     Dim ra1 As Range, ra2 As Range, ra3 As Range, ran As Range, a As String
   
3.     On Error Resume Next
   
4.     Set ra1 = Sheet1.UsedRange
   
5.     Set ra2 = Sheet2.UsedRange
   
6.     Set ra3 = Sheet3.UsedRange
   
7.     ra1.ClearContents
   
8.     ra1.ClearComments
   
9.     ra1.Resize(ra2.Rows.Count, ra2.Columns.Count).Value = ra2.Value
   
10.     Application.ScreenUpdating = False
    
11.     For Each ran In ra3
    
12.         If ran.Value <> "" And ran.Row > 1 Then
    
13.             a = ran.Formula
    
14.             
    
15.             '根据单元格格式类型显示对应格式的批注文本
    
16.             With ra1(ran.Row, ran.Column)
    
17.                 .NumberFormat = ran.NumberFormat
    
18.                 .AddComment Text:=a
    
19.                 .Comment.Visible = False
    
20.                 .Comment.Shape.Fill.Visible = msoFalse
    
21.             End With
    
22.         End If
    
23.     Next
    
24.     Set ran = Nothing
    
25.     Set ra1 = Nothing
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码