记录较多，想通过宏对应写入标注

奔跑之人

想通过宏，把《记录》里面的内容自动添加《填入》表格生成批注，见图。

taller

每个产品都有两行，区别是什么？

蓝桥玄霜

批注的例子：

FOB_FN_L

批注    是个很好的功能，但EH里用批注完成别的功能的贴子还不太多，前两天有个单元格记录改动的那个就是 最适用于批注的~~

shenjianrong163

1. Sub test()
   
2.     Dim i, j, d, k, m, arr, brr, s, str
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("记录")
   
5.         arr = .Range("B4:J" & .Cells(.Rows.Count, "j").End(xlUp).Row)
   
6.         For i = 1 To UBound(arr)
   
7.             If Not d.Exists(arr(i, 8) & "|" & arr(i, 1)) Then
   
8.                 d(arr(i, 8) & "|" & arr(i, 1)) = arr(i, 9)
   
9.             Else
   
10.                 d(arr(i, 8) & "|" & arr(i, 1)) = d(arr(i, 8) & "|" & arr(i, 1)) & "|" & arr(i, 9)
    
11.             End If
    
12.         Next
    
13.     End With
    
14.     With Sheets("填入")
    
15.         brr = .Range("A4:U" & .Cells(.Rows.Count, "u").End(xlUp).Row + 1)
    
16.         For i = 1 To UBound(brr)
    
17.             For j = 10 To UBound(brr, 2) - 1
    
18.                 If d.Exists(brr(1, j) & "|" & brr(i, UBound(brr, 2))) Then
    
19.                 s = Split(d(brr(1, j) & "|" & brr(i, UBound(brr, 2))), "|")
    
20.                 For k = 0 To UBound(s)
    
21.                     If UBound(s) = 0 Then
    
22.                         str = s(k)
    
23.                     Else
    
24.                         If m = UBound(s) Then
    
25.                             str = str & s(k) & "。"
    
26.                         Else
    
27.                             str = str & s(k) & "；" & vbCrLf
    
28.                         End If
    
29.                         m = m + 1
    
30.                     End If
    
31.                 Next
    
32.                 If Not .Cells(i + 4, j).Comment Is Nothing Then .Cells(i + 4, j).Comment.Delete '删除批注
    
33.                 .Cells(i + 4, j).AddComment "备注说明:" & vbCrLf & str '添加批注
    
34.                 End If
    
35.             Next
    
36.         Next
    
37.     End With
    
38. End Sub

复制代码

shenjianrong163

请参考附件：



Book.rar (17.5 KB, 下载次数: 10)

2020-3-15 13:08 上传

点击文件名下载附件
1

奔跑之人

shenjianrong163 发表于 2020-3-15 13:08
请参考附件：

多谢shenjianrong163老师。
刚才测试了一下，能达到效果，但如果记录有误，修正后再写入，则标注不能同时修正（原来错误的标注还存在）。
辛苦了，谢谢。

shenjianrong163

奔跑之人 发表于 2020-3-15 13:47
多谢shenjianrong163老师。
刚才测试了一下，能达到效果，但如果记录有误，修正后再写入，则标注不能同 ...

改一句即可：

1. Sub test()
   
2.     Dim i, j, d, k, m, arr, brr, s, str
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("记录")
   
5.         arr = .Range("B4:J" & .Cells(.Rows.Count, "j").End(xlUp).Row)
   
6.         For i = 1 To UBound(arr)
   
7.             If Not d.Exists(arr(i, 8) & "|" & arr(i, 1)) Then
   
8.                 d(arr(i, 8) & "|" & arr(i, 1)) = arr(i, 9)
   
9.             Else
   
10.                 d(arr(i, 8) & "|" & arr(i, 1)) = d(arr(i, 8) & "|" & arr(i, 1)) & "|" & arr(i, 9)
    
11.             End If
    
12.         Next
    
13.     End With
    
14.     With Sheets("填入")
    
15.         brr = .Range("A4:U" & .Cells(.Rows.Count, "u").End(xlUp).Row + 1)
    
16.         For i = 1 To UBound(brr)
    
17.             For j = 10 To UBound(brr, 2) - 1
    
18.                 If Not .Cells(i + 4, j).Comment Is Nothing Then .Cells(i + 4, j).Comment.Delete '删除批注
    
19.                 If d.Exists(brr(1, j) & "|" & brr(i, UBound(brr, 2))) Then
    
20.                 s = Split(d(brr(1, j) & "|" & brr(i, UBound(brr, 2))), "|")
    
21.                 For k = 0 To UBound(s)
    
22.                     If UBound(s) = 0 Then
    
23.                         str = s(k)
    
24.                     Else
    
25.                         If m = UBound(s) Then
    
26.                             str = str & s(k) & "。"
    
27.                         Else
    
28.                             str = str & s(k) & "；" & vbCrLf
    
29.                         End If
    
30.                         m = m + 1
    
31.                     End If
    
32.                 Next
    
33.                 .Cells(i + 4, j).AddComment "备注说明:" & vbCrLf & str '添加批注
    
34.                 End If
    
35.             Next
    
36.         Next
    
37.     End With
    
38. End Sub

复制代码