学以致用——使用VBA批量提取Excel中的备注（Extract Excel comments in batch）

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