Word合并工具

帮好兄弟的朋友写的一个小工具，就是把Word中的表格合并到Excel中去

下面是相关代码

Sub main()
     ' 清空表格
    Sheet1.Range("A5:AP20").ClearContents


    Set dirFSO = CreateObject("Scripting.FileSystemObject")
    Set wdapp = CreateObject("Word.Application")
    
    Set regEx = CreateObject("vbscript.regexp")
    regEx.Pattern = "\d+"
    regEx.IgnoreCase = True '设置是否区分大小写
    regEx.Global = True '设置全程匹配
    wdapp.Visible = False
    
    fileNum = 4

    ' 获得目录下所有的word文件
    filePath = Sheet1.Cells(1, 2).Value
    Set dirFiles = dirFSO.getfolder(filePath)
    For Each file In dirFiles.Files
        If dirFSO.getExtensionName(file.Path) = "doc" Or dirFSO.getExtensionName(file.Path) = "docx" Then
            ' 打开word 获取内容
            On Error GoTo Err_Handle
            Set worddoc = wdapp.Documents.Open(file.Path)
            Set objTable = worddoc.Tables(1)
            rowNum = fileNum + 1
            ' 序号
            Sheet1.Cells(rowNum, 1).Value = fileNum - 3
            ' 名称
            Sheet1.Cells(rowNum, 2).Value = Replace(objTable.Cell(1, 2).Range.Text, Chr$(13) & Chr$(7), "")
            ' 所属行业
            Sheet1.Cells(rowNum, 3).Value = Replace(objTable.Cell(5, 2).Range.Text, Chr$(13) & Chr$(7), "")
            ' 联系人
            Sheet1.Cells(rowNum, 4).Value = Replace(objTable.Cell(3, 2).Range.Text, Chr$(13) & Chr$(7), "")
            ' 联系电话
            Sheet1.Cells(rowNum, 5).Value = Replace(objTable.Cell(3, 4).Range.Text, Chr$(13) & Chr$(7), "")
            ' 员工人数
            ygrs = Replace(objTable.Cell(6, 2).Range.Text, Chr$(13) & Chr$(7), "")
            Sheet1.Cells(rowNum, 6).Value = Replace(ygrs, "人", "")
            ' 厂房面积（㎡）
            cfmj = Replace(objTable.Cell(7, 2).Range.Text, Chr$(13) & Chr$(7), "")
            If InStr(cfmj, "/") > 0 Then
                Sheet1.Cells(rowNum, 7).Value = Replace(Split(cfmj, "/")(0), "㎡", "")
            Else
                Sheet1.Cells(rowNum, 7).Value = "/"
            End If
            ' 仓库面积（㎡）
            ckmj = Replace(objTable.Cell(7, 4).Range.Text, Chr$(13) & Chr$(7), "")
            If InStr(ckmj, "/") > 0 Then
                Sheet1.Cells(rowNum, 8).Value = Replace(Split(ckmj, "/")(0), "㎡", "")
            Else
                 Sheet1.Cells(rowNum, 8).Value = "/"
            End If
            ' 产值（万元）
            cz = Replace(objTable.Cell(8, 4).Range.Text, Chr$(13) & Chr$(7), "")
            
            If InStr(cz, "万") > 0 Then
                 Sheet1.Cells(rowNum, 9).Value = Replace(cz, "万", "")
            Else
                 Sheet1.Cells(rowNum, 9).Value = "/"
            End If
            
            
            '特种设备解析
            tzsb = Replace(objTable.Cell(11, 2).Range.Text, Chr$(13) & Chr$(7), "")
            If tzsb = "" Then
                tzsb = "  "
            End If
            
            
            numbers = 0
            For i = 0 To UBound(Split(tzsb, "、"))
                ' 提取数字
                Set Matches = regEx.Execute(Split(tzsb, "、")(i))
                numbers = ""
                For Each Match In Matches
                    numbers = numbers + Match.Value
                Next
                
                If InStr(tzsb, "叉车") > 0 Then
                    Sheet1.Cells(rowNum, 10).Value = numbers
                    Sheet1.Cells(rowNum, 11).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 10).Value = "/"
                    Sheet1.Cells(rowNum, 11).Value = "/"
                End If
                
                If InStr(tzsb, "起重") > 0 Then
                    Sheet1.Cells(rowNum, 12).Value = numbers
                    Sheet1.Cells(rowNum, 13).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 12).Value = "/"
                    Sheet1.Cells(rowNum, 13).Value = "/"
                End If
                
                If InStr(tzsb, "电梯") > 0 Then
                    Sheet1.Cells(rowNum, 14).Value = numbers
                    Sheet1.Cells(rowNum, 15).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 14).Value = "/"
                    Sheet1.Cells(rowNum, 15).Value = "/"
                End If
                
                If InStr(tzsb, "锅炉") > 0 Then
                    Sheet1.Cells(rowNum, 16).Value = numbers
                    Sheet1.Cells(rowNum, 17).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 16).Value = "/"
                    Sheet1.Cells(rowNum, 17).Value = "/"
                End If
                
                If InStr(tzsb, "压力") > 0 Then
                    Sheet1.Cells(rowNum, 18).Value = Split(tzsb, "、")(i)
                    Sheet1.Cells(rowNum, 19).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 18).Value = "/"
                    Sheet1.Cells(rowNum, 19).Value = "/"
                End If
            Next
            
            tzsbry = Replace(objTable.Cell(11, 4).Range.Text, Chr$(13) & Chr$(7), "")
            
            If tzsbry = "" Then
                tzsbry = "  "
            End If
            
            numbers = 0
            For i = 0 To UBound(Split(tzsbry, "、"))
                ' 提取数字
                Set Matches = regEx.Execute(Split(tzsbry, "、")(i))
                numbers = ""
                For Each Match In Matches
                    numbers = numbers + Match.Value
                Next
                
                If InStr(tzsbry, "电工") > 0 Then
                    Sheet1.Cells(rowNum, 20).Value = numbers
                    Sheet1.Cells(rowNum, 21).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 20).Value = "/"
                    Sheet1.Cells(rowNum, 21).Value = "/"
                End If
                
                If InStr(tzsbry, "焊工") > 0 Then
                    Sheet1.Cells(rowNum, 22).Value = numbers
                    Sheet1.Cells(rowNum, 23).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 22).Value = "/"
                    Sheet1.Cells(rowNum, 23).Value = "/"
                End If
                
                If InStr(tzsbry, "叉车工") > 0 Then
                    Sheet1.Cells(rowNum, 24).Value = numbers
                    Sheet1.Cells(rowNum, 25).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 24).Value = "/"
                    Sheet1.Cells(rowNum, 25).Value = "/"
                End If
                
                If InStr(tzsbry, "行车工") > 0 Then
                    Sheet1.Cells(rowNum, 26).Value = numbers
                    Sheet1.Cells(rowNum, 27).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 26).Value = "/"
                    Sheet1.Cells(rowNum, 27).Value = "/"
                End If
                
                If InStr(tzsbry, "司炉工") > 0 Then
                    Sheet1.Cells(rowNum, 28).Value = numbers
                    Sheet1.Cells(rowNum, 29).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 28).Value = "/"
                    Sheet1.Cells(rowNum, 29).Value = "/"
                End If
                
                
                If InStr(tzsbry, "电梯操作工") > 0 Then
                    Sheet1.Cells(rowNum, 30).Value = numbers
                    Sheet1.Cells(rowNum, 31).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 30).Value = "/"
                    Sheet1.Cells(rowNum, 31).Value = "/"
                End If
                
                If InStr(tzsbry, "压力容器操作工") > 0 Then
                    Sheet1.Cells(rowNum, 32).Value = numbers
                    Sheet1.Cells(rowNum, 33).Value = "/"
                Else
                    Sheet1.Cells(rowNum, 32).Value = "/"
                    Sheet1.Cells(rowNum, 33).Value = "/"
                End If
            Next
            
            fileNum = fileNum + 1

        End If
    Next
    
MsgBox "处理完成", vbOKOnly, "星阳提醒"
Err_Handle:
    worddoc.Close False
    wdapp.Quit
End Sub