[已解决]请帮助修改代码

ms967967 · 发表于 2014-9-11 22:06

本帖最后由 ms967967 于 2014-9-12 06:01 编辑

网上度来的，需要做些改动，试了几次，自己还不能办到，麻烦路过的老师给修改一下，附件在楼下

最佳答案

dsmch

2014-9-11 23:59

Sub Macro1()
Dim arr, brr, d, i&, j%, zf$
Set d = CreateObject("scripting.dictionary")
arr = ActiveSheet.UsedRange
brr = Sheets("COA").Range("a1").CurrentRegion
For i = 3 To UBound(brr)
zf = ""
For j = 3 To 7
zf = zf & vbCrLf & Left(brr(2, j), 4) & ":" & IIf(j < 5, brr(i, j), Format(brr(i, j), "0.0"))
Next
d(brr(i, 2)) = Mid(zf, 3)
Next
For i = 2 To UBound(arr)
For j = 1 To UBound(arr, 2)
If d.exists(arr(i, j)) Then
With Cells(i, j)
.ClearComments
.AddComment d(arr(i, j))
End With
End If
Next
Next
End Sub

复制代码

ms967967 · 发表于 2014-9-11 22:06

根据条件插入批注.rar (16.05 KB, 下载次数: 6)

dsmch · 发表于 2014-9-11 23:59

Sub Macro1()
Dim arr, brr, d, i&, j%, zf$
Set d = CreateObject("scripting.dictionary")
arr = ActiveSheet.UsedRange
brr = Sheets("COA").Range("a1").CurrentRegion
For i = 3 To UBound(brr)
zf = ""
For j = 3 To 7
zf = zf & vbCrLf & Left(brr(2, j), 4) & ":" & IIf(j < 5, brr(i, j), Format(brr(i, j), "0.0"))
Next
d(brr(i, 2)) = Mid(zf, 3)
Next
For i = 2 To UBound(arr)
For j = 1 To UBound(arr, 2)
If d.exists(arr(i, j)) Then
With Cells(i, j)
.ClearComments
.AddComment d(arr(i, j))
End With
End If
Next
Next
End Sub

复制代码

dsmch · 发表于 2014-9-12 00:01

………………

		自动登录	找回密码
密码			注册