这个程序还是挺有成就感的,因为它帮我提取了近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