[已解决]匹配批注

chensir

把表1中店的批注内容，放入到表2相应店的批注里。
由于店4店5无批注，因此要求表2中的店4店5也无批注。

最佳答案

月排行榜 / 总排行榜

Zipall

2014-5-12 18:31

1. Sub test()
   
2.     'On Error Resume Next
   
3.     Dim r As Long, rng As Range, cmt As String
   
4.     With Sheets("表2")
   
5.         Set rng = Nothing
   
6.         For r = 2 To .Range("A65536").End(xlUp).Row
   
7.             .Cells(r, 2).ClearComments
   
8.             Set rng = Sheets("表1").Range("A:A").Find(.Cells(r, 1).Value, , , xlWhole)
   
9.             If Not rng Is Nothing Then
   
10.                 cmt = rng.Offset(, 1).Value
    
11.                 If Len(cmt) > 0 Then .Cells(r, 2).AddComment cmt
    
12.             End If
    
13.         Next
    
14.     End With
    
15. End Sub
    

复制代码

跳转到最佳答案楼层

Zipall

1. Sub test()
   
2.     'On Error Resume Next
   
3.     Dim r As Long, rng As Range, cmt As String
   
4.     With Sheets("表2")
   
5.         Set rng = Nothing
   
6.         For r = 2 To .Range("A65536").End(xlUp).Row
   
7.             .Cells(r, 2).ClearComments
   
8.             Set rng = Sheets("表1").Range("A:A").Find(.Cells(r, 1).Value, , , xlWhole)
   
9.             If Not rng Is Nothing Then
   
10.                 cmt = rng.Offset(, 1).Value
    
11.                 If Len(cmt) > 0 Then .Cells(r, 2).AddComment cmt
    
12.             End If
    
13.         Next
    
14.     End With
    
15. End Sub
    

复制代码

云影

1. Sub test()
   
2.     Dim x%, y%
   
3.     With Sheet1
   
4.         For x = 2 To .Cells(Rows.Count, 1).End(3).Row
   
5.             For y = 2 To Sheet2.Cells(Rows.Count, 1).End(3).Row
   
6.                 If .Cells(x, 1) = Sheet2.Cells(y, 1) Then
   
7.                     If .Cells(x, 2) <> "" Then
   
8.                         With Sheet2.Cells(y, 2)
   
9.                             .AddComment
   
10.                             .Comment.Visible = 1
    
11.                             .Comment.text text:=Sheet1.Cells(x, 2).Value
    
12.                         End With
    
13.                     End If
    
14.                 End If
    
15.             Next y
    
16.         Next x
    
17.     End With
    
18. End Sub

复制代码

yuan1987

楼上大神们的杰作啊

xdragon

1. Sub t()
   
2.   Dim i As Long, d As Object, arr
   
3.   Set d = CreateObject("scripting.dictionary")
   
4.   arr = Sheet1.Range("A1").CurrentRegion.Value
   
5.   For i = 1 To UBound(arr)
   
6.     If Len(arr(i, 2)) > 0 Then d(arr(i, 1)) = arr(i, 2)
   
7.   Next
   
8.   On Error Resume Next
   
9.   With Sheet2
   
10.     For i = 2 To .Range("A1").CurrentRegion.Rows.Count
    
11.       If d.exists(.Cells(i, 1).Value) Then
    
12.         .Range("B" & i).Comment.Delete
    
13.         With .Range("B" & i).AddComment
    
14.           .Visible = False
    
15.           .Text CStr(d(Sheet2.Cells(i, 1).Value))
    
16.         End With
    
17.       End If
    
18.     Next
    
19.   End With
    
20. End Sub

复制代码

su45

哈哈……，高手如云呀！

chensir

谢谢，各位