[已解决]提取批注

ms967967

用VBA批量提取单元格及批注内容。如附件结果
附件在楼下

最佳答案

月排行榜 / 总排行榜

这儿有肥猫

2014-9-18 20:36

1. Sub a()
   
2. Dim i&, j&, arr, brr(), s&, crr()
   
3. arr = Sheets("内容").Range("b3:f12")
   
4. s = 0
   
5. For j = 1 To UBound(arr, 2)
   
6.     For i = 1 To UBound(arr)
   
7.    
   
8.         If arr(i, j) <> 0 Then
   
9.            n = n + 1
   
10.            ReDim Preserve brr(1 To n)
    
11.            ReDim Preserve crr(1 To n)
    
12.            brr(n) = arr(i, j)
    
13.            crr(n) = Sheets("内容").Cells(i + 2, j + 1).Comment.Text
    
14.         End If
    
15.     Next
    
16. Next
    
17. Sheets("结果").[a2:b65536].ClearContents
    
18. Sheets("结果").[a2].Resize(n, 1) = Application.Transpose(brr)
    
19. Sheets("结果").[b2].Resize(n, 1) = Application.Transpose(crr)
    
20. 
    
21. End Sub
    

复制代码

跳转到最佳答案楼层

ms967967

提取批注.rar (9.01 KB, 下载次数: 20)

2014-9-18 20:20 上传

点击文件名下载附件

这儿有肥猫

1. Sub a()
   
2. Dim i&, j&, arr, brr(), s&, crr()
   
3. arr = Sheets("内容").Range("b3:f12")
   
4. s = 0
   
5. For j = 1 To UBound(arr, 2)
   
6.     For i = 1 To UBound(arr)
   
7.    
   
8.         If arr(i, j) <> 0 Then
   
9.            n = n + 1
   
10.            ReDim Preserve brr(1 To n)
    
11.            ReDim Preserve crr(1 To n)
    
12.            brr(n) = arr(i, j)
    
13.            crr(n) = Sheets("内容").Cells(i + 2, j + 1).Comment.Text
    
14.         End If
    
15.     Next
    
16. Next
    
17. Sheets("结果").[a2:b65536].ClearContents
    
18. Sheets("结果").[a2].Resize(n, 1) = Application.Transpose(brr)
    
19. Sheets("结果").[b2].Resize(n, 1) = Application.Transpose(crr)
    
20. 
    
21. End Sub
    

复制代码

ms967967

这儿有肥猫 发表于 2014-9-18 20:36

感谢您的帮助，我在测试时发现，当数据列中间有空单元格时报错不执行，如何调整。请再次支持，谢谢。

这儿有肥猫

ms967967 发表于 2014-9-19 09:20
感谢您的帮助，我在测试时发现，当数据列中间有空单元格时报错不执行，如何调整。请再次支持，谢谢。

应该不会啊，截个图呢？

ms967967

这儿有肥猫 发表于 2014-9-19 09:35
应该不会啊，截个图呢？

好了，是我工作表的问题。