【VBA】提取 Word|PPT|Excel 批注实例（Excel一键导入办公文档中的批注）

VBAEXCEL多表合并批注整理
源文件，下载后可直接体验

相关学习链接推荐：

Office Visual Basic for Applications (VBA) 参考 | Microsoft Docs

Excel VBA 编程教程_w3cschool

Excel VBA工作应用经典十例_哔哩哔哩_bilibili

以上是相关学习教程，仅供参考！！！

---

学习过程中的整理的相关代码与实例都在下文了！！！

1. 基础代码整理

2. 多表合并代码

多表合并表头相同的情况下，实现多表合并，具体细节根据注释需要自己去完善代码

Public Sub ll()
    Dim sa As Worksheet
    Dim ab As Integer
    Dim sc As Range
    
    Sheet4.Activate
    For Each sa In Worksheets
        If sa.Name <> ActiveSheet.Name Then
        ' 下边提取活动表,也就是sheet4从A65536及顶端的数据,Offset是返回除指定区域以外的区域
        ' 需要注意这里的Range("A65536")需要尽可能设置大一点，不然会造成多表内容覆盖
        ' 举个例子，有5张row为10表，如果这里的A65536设置为10，那么sheet会被这10张表反复替代，最后运行的是哪张表，sheet4就保存的是哪张表
        	Set sc = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
    		' 获取行数为被复制表的（非标题行）
        	sb = sa.Range("a1").CurrentRegion.Rows.Count - 1
    		' 表的拷贝
            sa.Range("a2").Resize(sb, 5).Copy sc
        End If
    Next

End Sub

挂上上述代码中的相关链接，方便查看，里边有相关函数的Demo，一看就懂：

• .End()函数

返回一个 Range 对象，它表示包含源范围的区域末尾的单元格。 相当于按 End+向上键、End+向下键、End+向左键或 End+向右键。 此为只读 Range 对象。

• .Offset()函数

返回一个 Range 对象，它表示指定区域以外的一个区域。

• Worksheet.Range 属性

返回一个 Range 对象，它表示一个单元格或单元格区域。

' 附上完整版代码
Public Sub ll()
    Dim sa As Worksheet
    Dim ab As Integer
    Dim sc As Range
    Dim NumOfSheet As Integer
    Dim WSN As String
    
    NumOfSheet = 0
    Sheet6.Activate
    For Each sa In Worksheets
        If sa.Name <> ActiveSheet.Name Then
            NumOfSheet = NumOfSheet + 1
        
            Set sc = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
            
            sb = sa.Range("a1").CurrentRegion.Rows.Count - 1
            
            sa.Range("a2").Resize(sb, 5).Copy sc
            
            WSN = WSN & Chr(13) & sa.Name

        End If
    Next
    MsgBox "共合并了" & Num & "个工作表。如下：" & Chr(13) & WSN, vbInformation, "提示"

End Sub

实例①: 合并多个excel

合并多个excel中多个sheet，每个sheet单独合并

' 合并多个excel中多个sheet，每个sheet单独合并
Sub 合并当前目录下所有工作簿的全部工作表()
    Dim MyPath, MyName, AWbName
    Dim WbAs Workbook, WbNAs String
    Dim GAs Long
    Dim NumAs Long
    Dim BOXAs String
    flag = 0
     
    Application.ScreenUpdating =False
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath &"\" & "*.xls")
    AWbName = ActiveWorkbook.Name
    Num = 0
  
     
    Do While MyName <>""
        If MyName <> AWbNameThen
            Set Wb = Workbooks.Open(MyPath & "\" & MyName)
            Num = Num + 1
             
             
                For G = 1To Wb.Sheets.Count
                     
                    If flag = 0Then
                    Sheets.Add after:=Sheets(Sheets.Count)
                     
                        With ActiveSheet
                               .Name = Wb.Sheets(G).Name
                           Wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row, 1)
                           .UsedRange.Rows.AutoFit
                           .UsedRange.Columns.AutoFit
                        End With
                    Else
                          With Workbooks(1).Worksheets(G + 3)
                          ' MsgBox .Name & "--" & Wb.Sheets(G).Name
                           If G = 2Then
                            Wb.Sheets(G).Range("a2", Wb.Sheets(G).Cells.SpecialCells(xlCellTypeLastCell)).Copy .Cells(.Range("A65536").End(xlUp).Row + 2, 1)
                           Else
                            Wb.Sheets(G).Range("a2", Wb.Sheets(G).Cells.SpecialCells(xlCellTypeLastCell)).Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
                            End If
                             
                           .UsedRange.Rows.AutoFit
                           .UsedRange.Columns.AutoFit
                          End With
                           
                    End If
                Next
                'flag 为0时候为第一个打开的excel，此时产生列，sheet名
                 flag = 1
                WbN = WbN & Chr(13) & Wb.Name
                Wb.CloseFalse
           ' End With
        End If
        MyName = Dir
    Loop
        Range("A1").Select
         
         
    Application.ScreenUpdating =True
    MsgBox"共合并了" & Num &"个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation,"提示"
End Sub

实例②: 设置单元格有效性

Sub dataValidity()
    Dim oWK As Worksheet
    Dim oRng As Range
    Set oWK = Excel.ActiveSheet
    Set oRng = oWK.Range("a1:a100")
    With oRng.Validation
        '先删除之前的数据有效性
        .Delete
        '再添加新的数据有效性下拉列表
        .Add Type:=xlValidateList, Formula1:="红,黄,蓝,绿"
    End With
End Sub

3. 提取批注

提取批注

' 提取批注
Sub AllCommentsList()

    '声明变量

    Dim wb As Workbook

    Dim ws As Worksheet

    Dim cmt As Comment

    Dim lngCmtCount As Long

   

    '赋初始值,代表第2行

    lngCmtCount = 2

   

    '关闭屏幕刷新

    Application.ScreenUpdating = False

   

    '新建带有1个工作表的工作簿

    Set wb = Workbooks.Add(xlWorksheet)

   

    '在新建的工作簿中输入标题行

    With wb.Sheets(1)

        .Range("A1") = "作者"

        .Range("B1") = "工作簿"

        .Range("C1") = "工作表"

        .Range("D1") = "单元格"

        Range("E1") = "批注"

    End With

   

    '遍历代码所在的工作簿中的工作表

    For Each ws In ThisWorkbook.Worksheets

        '遍历工作表中的批注

        For Each cmt In ws.Comments

            '将批注信息输入新工作簿中

            With wb.Sheets(1)

                '批注作者

                .Cells(lngCmtCount, 1) = cmt.author

                '批注所在工作簿名

                .Cells(lngCmtCount, 2) = cmt.Parent.Parent.Parent.Name

                '批注所在工作表名

                .Cells(lngCmtCount, 3) = cmt.Parent.Parent.Name

                '批注所在单元格地址

                .Cells(lngCmtCount, 4) = cmt.Parent.Address

                '批注内容,调用子过程来清理批注内容

                .Cells(lngCmtCount, 5) = CleanComment(cmt.author, cmt.Text)

            End With

           

            '增加行计数

            lngCmtCount = lngCmtCount + 1

        Next cmt

    Next ws

   

    '设置单元格区域不换行

    wb.Sheets(1).UsedRange.WrapText = False

   

    '关闭屏幕刷新

    Application.ScreenUpdating = True

   

    '释放对象变量

    Set ws = Nothing

    Set wb = Nothing

End Sub

 

'清理批注内容

Private Function CleanComment(author As String, cmt As String) As String

    Dim tmp As String

   

    '去掉批注作者

    tmp = Application.WorksheetFunction.Substitute(cmt, author & ":", "")

    '去掉批注中多余的空格

    tmp = Application.WorksheetFunction.Substitute(tmp, Chr(10), "")

   

    '返回清理后的批注内容

    CleanComment = tmp

End Function

N. 基础代码整理

1）刷屏

' 执行程序前设置为False
Application.ScreenUpdatin = False ' 关闭刷屏
' 执行后设置为True
Application.ScreenUpdatin = True

个人撰写代码-提取批注

' 定义全局变量存放文件名
Public Sub globalFun()
    Public arr() As String
    Public fileNum As Integer
End Sub
'运行
Public Sub CommandButtonRun_Click()

    Dim l As Long
    
    Dim files As String
    
    fileNum = 0
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True   '单选择
        .Filters.Clear   '清除文件过滤器
        .Filters.Add "Excel Files", "*.xlsx;*.xlsm;*.xls;*.csv"
        .Filters.Add "All Files", "*.*"          '设置两个文件过滤器
        
        If .Show = -1 Then
            ReDim arr(1 To .SelectedItems.Count) As String
                For l = 1 To .SelectedItems.Count
                    fileNum = fileNum + 1
                    files = files & Chr(13) & .SelectedItems(l) & Chr(10)
                    arr(l) = .SelectedItems(l)
                Next
        Else
            MsgBox "未选择文件", vbCritical, "警告"
            GoTo runEnd
        End If
        
        MsgBox "您选择的文件是：" & files, vbOKOnly + vbInformation, "提示"
        ThisWorkbook.Sheets("Sheet1").Range("G11") = files
            
        Call HighLightPath(11)
        
    End With
    
    
    'creatFile
    
    Call creatSheet(arr(), fileNum)
    
runEnd:
    End Sub
Public Sub HighLightPath(row As Integer)
    Dim s%
    Application.ScreenUpdating = False
    ' MsgBox Len(Cells(4, 7)), vbInformation, "提示"
    
    For j = 1 To Len(Cells(row, 7))
        If Mid(Cells(row, 7), j, 1) = "\" Then
            s = j
            With Cells(row, 7).Characters(s, 1)
                .Font.ColorIndex = 3
                .Font.Bold = True
                .Font.Size = 9
            End With
        End If
    Next j
    
    Application.ScreenUpdating = True
End Sub
Private Sub creatSheet(ByRef fileArr() As String, ByVal fileNum As Integer)
        
    Dim ws As Worksheet
   
    Dim FileName As String
   
    Dim wb As Workbook
   
    Dim index As Integer
   
    Application.ScreenUpdating = False
   
   'step1---------------------------------------------------
    
   '创建新工作簿
    If OptionButtonNewBook.Value Then
       
       Set wb = Workbooks.Add
       
       Set ws = wb.Sheets("Sheet1")
       
       '判断是否已有该文件
        If FileFolderExists(FileName) = True Then
            For i = 1 To 100
                FileName = ThisWorkbook.Path & "\" & "批注(" & i & ")-" & ThisWorkbook.Name
                If FileFolderExists(FileName) = False Then
                    Call initSheet(ws)
                    MsgBox "文件创建路径为" + Chr(13) + FileName, vbOKOnly + vbInformation, "提示"
                    wb.SaveAs FileName:=FileName
                    Exit For
                End If
            Next i
        End If
        
    '当前工作簿
    Else
    
        FileName = "当前工作簿（" & ThisWorkbook.Name & ")"
       
        Set ws = Worksheets.Add
        
        MsgBox "新表已创建", vbOKOnly + vbInformation, "提示"
       
        Call initSheet(ws)
       
    End If
   
    Call HighLightPath(14)
    
    'step2---------------------------------------------------
    '写入批注
    '遍历代码所在的工作簿中的工作表
    Dim tws As Worksheet
    
    Dim twb As Workbook
    
    Dim cmt As Comment

    Dim lngCmtCount As Long
    
    
    '赋初始值,代表第4行

    lngCmtCount = 4
    
    '赋初始值,序号
    
    index = 1
    
    For i = 1 To fileNum
    
        '新建带有1个工作表的工作簿

        Set twb = Workbooks.Open(fileArr(i))
        
        For Each tws In twb.Worksheets
    
            '遍历工作表中的批注
    
            For Each cmt In tws.Comments
    
                '将批注信息输入新工作簿中
    
                With ws
    
                    '批注作者
    
                    .Cells(lngCmtCount, 1) = index
                    
                    index = index + 1
    
                    '批注所在工作簿名
    
                    .Cells(lngCmtCount, 2) = cmt.Parent.Parent.Parent.Name
    
                    '批注所在工作表名
    
                    .Cells(lngCmtCount, 3) = cmt.Parent.Parent.Name
    
                    '批注所在单元格地址
    
                    .Cells(lngCmtCount, 4) = cmt.Parent.Address
    
                    '批注内容,调用子过程来清理批注内容
    
                    .Cells(lngCmtCount, 5) = CleanComment(cmt.author, cmt.Text)
    
                End With
    
               
    
                '增加行计数
    
                lngCmtCount = lngCmtCount + 1
    
            Next cmt
    
        Next tws
    
    Next

    wb.SaveAs FileName:=FileName
    '---------------------------------------------------

MyEnd:
    
    ThisWorkbook.Sheets("Sheet1").Range("G14") = FileName
    Application.ScreenUpdating = True

End Sub
'判断文件是否存在
Public Function FileFolderExists(strFullPath As String) As Boolean

    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
    On Error GoTo 0

End Function

'清理批注内容

Private Function CleanComment(author As String, cmt As String) As String

    Dim tmp As String

   

    '去掉批注作者

    tmp = Application.WorksheetFunction.Substitute(cmt, author & ":", "")

    '去掉批注中多余的空格

    tmp = Application.WorksheetFunction.Substitute(tmp, Chr(10), "")

   

    '返回清理后的批注内容

    CleanComment = tmp

End Function

Public Sub writeMemo(ByVal ws As Worksheet, ByRef fileArr() As String, ByVal fileNum As Integer)

    
    '写入批注
    For i = 1 To fileNum
    
        '新建带有1个工作表的工作簿

        Set wb = Workbooks.Open: FileName = fileArr(i)
    
    
        'TODO
        '遍历代码所在的工作簿中的工作表
        
        For Each ws In wb.Worksheets
    
            '遍历工作表中的批注
    
            For Each cmt In ws.Comments
    
                '将批注信息输入新工作簿中
    
                With ws
    
                    '批注作者
    
                    .Cells(lngCmtCount, 1) = index
                    
                    index = index + 1
    
                    '批注所在工作簿名
    
                    .Cells(lngCmtCount, 2) = cmt.Parent.Parent.Parent.Name
    
                    '批注所在工作表名
    
                    .Cells(lngCmtCount, 3) = cmt.Parent.Parent.Name
    
                    '批注所在单元格地址
    
                    .Cells(lngCmtCount, 4) = cmt.Parent.Address
    
                    '批注内容,调用子过程来清理批注内容
    
                    .Cells(lngCmtCount, 5) = CleanComment(cmt.author, cmt.Text)
    
                End With
    
               
    
                '增加行计数
    
                lngCmtCount = lngCmtCount + 1
    
            Next cmt
    
        Next ws
    
    Next

End Sub
Public Function initSheet(ByRef ws As Worksheet)
    
    '设置表头格式
    With ws
        .Range("A3") = "#"
        .Range("B3") = "文件名"
        .Range("C3") = "表格"
        .Range("D3") = "单元格"
        .Range("E3") = "批注内容"
        .Range("F3") = "严重程度"
        ' --------
        
        .Range("G3") = "文档审核人"
        .Range("H3") = "审核时间"
        .Range("I3") = "发现时机"
        .Range("J3") = "修改方案"
        .Range("K3") = "评审确认"
        .Range("L3") = "计划修改时间"
        .Range("M3") = "修改人"
        .Range("N3") = "验证人"
        .Range("O3") = "缺陷状态"
        .Range("P3") = "验证关闭时间"
        .Range("Q3") = "备注"
        
        With .Rows("3:3").Select
            Selection.Font.Size = 11
            Selection.Font.Bold = True
            Selection.Font.Name = "宋体"
            Selection.HorizontalAlignment = xlHAlignCenter
            Selection.WrapText = False
        End With
        
        '设置A3I3背景颜色
        .Range("A3:I3").Select
        With Selection.Interior
            .Pattern = xlPatternSolid
            .Color = 65535
            .TintAndShade = 0
            .PatternColorIndex = -4105
        End With
        
        '设置J3:M3背景颜色
        .Range("J3:M3").Select
        With Selection.Interior
            .Pattern = xlPatternSolid
            .Color = 192
            .TintAndShade = 0
            .PatternColorIndex = -4105
        End With
        
        '设置N3:P3背景颜色
        .Range("N3:P3").Select
        With Selection.Interior
            .Pattern = xlPatternSolid
            .Color = 5287936
            .TintAndShade = 0
            .PatternColorIndex = -4105
        End With
        
        '设置Q3背景颜色
        .Range("Q3").Select
        With Selection.Interior
            .Pattern = xlPatternSolid
            .ThemeColor = 1
            .TintAndShade = -0.5
            .PatternColorIndex = -4105
        End With
          
    
    
    
    '设置边框
    With .Range("A3:Q1000").Select
        With Selection.Borders(xlEdgeLeft)
            .Weight = xlThin
            .LineStyle = xlContinuous
        End With
        With Selection.Borders(xlEdgeTop)
            .Weight = xlThin
            .LineStyle = xlContinuous
        End With
        With Selection.Borders(xlEdgeBottom)
            .Weight = xlThin
            .LineStyle = xlContinuous
        End With
        With Selection.Borders(xlEdgeRight)
            .Weight = xlThin
            .LineStyle = xlContinuous
        End With
        With Selection.Borders(xlInsideVertical)
            .Weight = xlThin
            .LineStyle = xlContinuous
        End With
        With Selection.Borders(xlInsideHorizontal)
            .Weight = xlThin
            .LineStyle = xlContinuous
        End With
        Selection.Borders(xlEdgeLeft).ColorIndex = xlColorIndexAutomatic
        Selection.Borders(xlEdgeTop).ColorIndex = xlColorIndexAutomatic
        Selection.Borders(xlEdgeBottom).ColorIndex = xlColorIndexAutomatic
        Selection.Borders(xlEdgeRight).ColorIndex = xlColorIndexAutomatic
        Selection.Borders(xlInsideVertical).ColorIndex = xlColorIndexAutomatic
        Selection.Borders(xlInsideHorizontal).ColorIndex = xlColorIndexAutomatic
    End With
        
        '设置自动列宽
        With .Range("A3:Q3").Select
            Selection.AutoFit
        End With
        
        '添加批注
        With .Range("E3").Select
            Selection.AddComment Text:="批注内容较多时，高亮显示"
        End With
        
        '设置缺陷描述和修改方案宽度
        With .Columns("E:E").Select
            Selection.ColumnWidth = 28.5
        End With
        
        With .Columns("J:J").Select
            Selection.ColumnWidth = 28.5
        End With
    
        '设置大标题
        With .Range("A1:Q2").Select
            With Selection
                .Merge Across:=False
                .HorizontalAlignment = xlHAlignCenter
            End With
        End With

        With .Range("A1")
            .Formula = "缺陷汇总跟踪表"
            With .Characters.Font
                .Name = "宋体"
                .Bold = True
                .Italic = False
                .Strikethrough = False
                .Superscript = False
                .Subscript = False
                .ThemeColor = 2
                .TintAndShade = 0
                .Underline = xlUnderlineStyleNone
                .Size = 20
            End With
        End With
            
        '冻结窗格
        .Range("R4").Activate
            ActiveWindow.FreezePanes = True
        
        '设置自动换行
        With .Range("A3:Q3").Select
            Selection.WrapText = True
        End With
    
        '设置表头高度
        .Rows("2:2").RowHeight = 33
        .Rows("3:3").RowHeight = 32
        
        '设置批注内容长度大于20的背景色
        With .Range("E4:E1048576").Select
            Selection.FormatConditions.Add Type:=xlExpression, Operator:=-1, Formula1:="=LEN(E4)>20", Formula2:=""
            Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
            Selection.FormatConditions(1).Interior.Pattern = xlPatternSolid
            Selection.FormatConditions(1).Interior.PatternColorIndex = -4105
            Selection.FormatConditions(1).Interior.PatternTintAndShade = 0
            Selection.FormatConditions(1).Interior.ThemeColor = 10
            Selection.FormatConditions(1).Interior.TintAndShade = 0.6
            Selection.FormatConditions(1).StopIfTrue = False
        End With
            
        '设置表头筛选
        With .Rows("3:3").Select
            Selection.AutoFilter
            ActiveWorkbook.Names.Add Name:="Sheet1!_FilterDatabase", RefersTo:="=Sheet1!$A$3:$Q$3", Visible:=False
            Selection.Select
        End With
        
        With .Columns("A:A").Select
            Selection.HorizontalAlignment = xlHAlignCenter
            Selection.VerticalAlignment = xlVAlignCenter
        End With
    
        '设置K\F列条件格式
        Call SetFormat(ws)
    End With
    
    '设置单元格区域不换行
    ws.UsedRange.WrapText = True
    
End Function

Public Sub SetFormat(ByRef ws As Worksheet)
    With ws.Range("F4:F1048576")
        .FormatConditions.Add Type:=xlTextString, String:="严重", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Pattern = xlPatternSolid
        .FormatConditions(1).Interior.PatternColorIndex = -4105
        .FormatConditions(1).Interior.PatternTintAndShade = 0
        .FormatConditions(1).Interior.Color = 192
        .FormatConditions(1).Interior.TintAndShade = 0
        .FormatConditions(1).StopIfTrue = False
        .FormatConditions.Add Type:=xlTextString, String:="一般", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Pattern = xlPatternSolid
        .FormatConditions(1).Interior.PatternColorIndex = -4105
        .FormatConditions(1).Interior.PatternTintAndShade = 0
        .FormatConditions(1).Interior.Color = 49407
        .FormatConditions(1).Interior.TintAndShade = 0
        .FormatConditions(1).StopIfTrue = False
        .FormatConditions.Add Type:=xlTextString, String:="轻微", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Pattern = xlPatternSolid
        .FormatConditions(1).Interior.PatternColorIndex = -4105
        .FormatConditions(1).Interior.PatternTintAndShade = 0
        .FormatConditions(1).Interior.ThemeColor = 10
        .FormatConditions(1).Interior.TintAndShade = 0
        .FormatConditions(1).StopIfTrue = False
    End With
    
    With ws.Range("K4:K1048576")
        .FormatConditions.Add Type:=xlTextString, String:="接受", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Pattern = xlPatternSolid
        .FormatConditions(1).Interior.PatternColorIndex = -4105
        .FormatConditions(1).Interior.PatternTintAndShade = 0
        .FormatConditions(1).Interior.ThemeColor = 10
        .FormatConditions(1).Interior.TintAndShade = 0
        .FormatConditions(1).StopIfTrue = False
        .FormatConditions.Add Type:=xlTextString, String:="拒绝", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Pattern = xlPatternSolid
        .FormatConditions(1).Interior.PatternColorIndex = -4105
        .FormatConditions(1).Interior.PatternTintAndShade = 0
        .FormatConditions(1).Interior.Color = 192
        .FormatConditions(1).Interior.TintAndShade = 0
        .FormatConditions(1).StopIfTrue = False
        .FormatConditions.Add Type:=xlTextString, String:="重复", TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.Pattern = xlPatternSolid
        .FormatConditions(1).Interior.PatternColorIndex = -4105
        .FormatConditions(1).Interior.PatternTintAndShade = 0
        .FormatConditions(1).Interior.Color = 49407
        .FormatConditions(1).Interior.TintAndShade = 0
        .FormatConditions(1).StopIfTrue = False
    End With
    
End Sub