这个程序还是挺有成就感的,因为它帮我提取了近4000行的Excel属性、方法、事件的说明。
我感觉原格式就是通过批量插入备注的方式制作而成的,而又被我通过VBA代码给复原了。一不小心完成了一个逆向工程,哈哈。
原格式:
提取后的格式:
新代码:
优点:
1. 不会造成文件的锁定
2.增加了备注所在单元格的行号和列标,有利于整理资料
3. 运行速度提高很多
待完善的地方:
目前没有采用数组的方式向Excel中写入值,如果采用数组方式,运行效率将大大提高
Sub getCommentsExcel() Dim objFile As Excel.Workbook Dim objSht As Excel.Worksheet Dim objRange As Excel.Range Dim varComment As String Dim c As Comment Dim cel As Range Dim n As Integer Dim savedFileName As String Application.DisplayAlerts = False Application.ScreenUpdating = False savedFileName = "C:\Users\[UserName]\Documents\xlComments2.xlsx" Set objFile = Workbooks.Open(savedFileName) objFile.Activate Set objSht = objFile.Worksheets("Sheet1") objSht.Visible = True objSht.Activate objSht.UsedRange.ClearContents 'This clears existing data With ThisWorkbook.Worksheets("Excel???????") For Each cel In .Range("A1:Q2396") On Error Resume Next Set c = cel.Comment If Not c Is Nothing Then n = n + 1 varComment = n & "_" & cel.Value & "_" & c.Text & vbCrLf Debug.Print varComment objSht.Range("A" & n).Value = n objSht.Range("B" & n).Value = cel.Value objSht.Range("C" & n).Value = c.Text objSht.Range("D" & n).Value = cel.Row objSht.Range("E" & n).Value = cel.Column End If Next End With objFile.SaveAs filename:=savedFileName, ReadOnlyRecommended:=False Application.Workbooks.Open (savedFileName) objFile.Sheet1.Activate Set objFile = Nothing Application.DisplayAlerts = False Application.ScreenUpdating = False End Sub
旧代码(会造成文件的锁定):
Sub getCommentsExcel() Dim objFSO As Excel.Application Dim objFile As Excel.Workbook Dim objSht As Excel.Worksheet Dim objRange As Excel.Range Dim varComment As String Dim c As Comment Dim cel As Range Dim n As Integer Dim savedFileName As String Application.DisplayAlerts = False savedFileName = "C:\Users\[UserName]\Documents\xlComments8.xlsx" Set objFSO = CreateObject("excel.Application") Set objFile = objFSO.Workbooks.Open(savedFileName) objFile.Activate Set objSht = objFile.Worksheets("Sheet1") objSht.UsedRange.ClearContents 'This clears existing data With ThisWorkbook.Worksheets("Excel???????") For Each cel In Range("K7:Q2396") On Error Resume Next Set c = cel.Comment If Not c Is Nothing Then n = n + 1 varComment = n & "_" & cel.Value & "_" & c.Text & vbCrLf Debug.Print varComment objSht.Range("A" & n).Value = n objSht.Range("B" & n).Value = cel.Value objSht.Range("C" & n).Value = c.Text End If Next End With objFile.SaveAs filename:=savedFileName, ReadOnlyRecommended:=False Application.Workbooks.Open (savedFileName) objFile.Sheet1.Activate Set objFile = Nothing Application.DisplayAlerts = False End Sub