zoukankan      html  css  js  c++  java
  • 20170922xlVBA_GetCellTextFromWordDocument

    Sub GetCellTextFromWordDocument()
        '应用程序设置
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.Calculation = xlCalculationManual
        
        '错误处理
        'On Error GoTo ErrHandler
        
        '计时器
        Dim StartTime, UsedTime As Variant
        StartTime = VBA.Timer
        
        '变量声明
        Dim Wb As Workbook
        Dim Sht As Worksheet
        Dim Rng As Range
        'Dim Arr As Variant
        Dim i As Long
        Dim EndRow As Long
        
        '实例化对象
        Set Wb = Application.ThisWorkbook
        Set Sht = Wb.Worksheets("提取信息")
        With Sht
            .UsedRange.Offset(1).ClearContents
        End With
        
        Dim FolderPath As String
        Dim FileName As String
        Dim Tb As Word.Table
        Dim FileCount As Long
        Dim WdApp As Word.Application
        Dim OpenDoc As Word.Document
        Dim wdRng As Object
        Dim Arr() As String
        ReDim Arr(1 To 10, 1 To 1)
        index = 0
        
        FolderPath = Wb.Path & "文档1"    '此处填入路径
        FileName = Dir(FolderPath & "*.doc*")
        FileCount = 0
        Set WdApp = New Word.Application
        'WdApp.Visible = True
        Do While FileName <> ""
            Debug.Print FileName
            FileCount = FileCount + 1
            
            Set OpenDoc = WdApp.Documents.Open(FolderPath & FileName)
            For Each Tb In OpenDoc.Tables
                If Tb.Cell(1, 1).Range.Text Like "*序号*" Then
                    index = index + 1
                    ReDim Preserve Arr(1 To 10, 1 To index)
                    With Tb
                        Arr(1, index) = RepSymbol(.Cell(3, 4).Range.Text)
                        Arr(2, index) = RepSymbol(.Cell(24, 3).Range.Text)  '父姓名
                        Arr(3, index) = RepSymbol(.Cell(25, 4).Range.Text)  '父地址
                        Arr(4, index) = "'" & RepSymbol(.Cell(27, 3).Range.Text)  '父电话
                        Arr(5, index) = RepSymbol(.Cell(29, 3).Range.Text)  '母姓名
                        Arr(6, index) = RepSymbol(.Cell(30, 4).Range.Text)  '母地址
                        Arr(7, index) = "'" & RepSymbol(.Cell(32, 3).Range.Text)   '母电话
                        Arr(8, index) = RepSymbol(.Cell(10, 4).Range.Text)  '户地址
                        Arr(9, index) = RepSymbol(.Cell(14, 4).Range.Text)  '现地址
                        Arr(10, index) = RegGet(FileName, "(d+)")
                    End With
                End If
            Next Tb
            OpenDoc.Close True
            
            With Sht
                EndRow = .Cells.Find("*", .Cells(1, 1), xlValues, xlWhole, xlByRows, xlPrevious).Row + 1
                Set Rng = .Cells(EndRow, 1)
                Set Rng = Rng.Resize(UBound(Arr, 2), UBound(Arr))
                Rng.Value = Application.WorksheetFunction.Transpose(Arr)
            End With
            FileName = Dir
        Loop
        
        'WdApp.Quit
        
    UsedTime = VBA.Timer - StartTime
        Debug.Print "UsedTime :" & Format(UsedTime, "#0.0000 Seconds")
       'MsgBox "UsedTime :" & Format(UsedTime, "#0.0000 Seconds")
    
    ErrorExit:                    '错误处理结束,开始环境清理
        Set Wb = Nothing
        Set Sht = Nothing
        Set Rng = Nothing
        Set WdApp = Nothing
        Set OpenDoc = Nothing
        
        
        
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic
        Exit Sub
    ErrHandler:
        If Err.Number <> 0 Then
            MsgBox Err.Description & "!", vbCritical, "错误提示!"
            'Debug.Print Err.Description
            Err.Clear
            Resume ErrorExit
        End If
    End Sub
    
    Function RepSymbol(ByVal Text As String) As String
        Dim NewText As String
        NewText = Text
        NewText = Replace(NewText, vbTab, "")
        NewText = Replace(NewText, vbCr, "")
        NewText = Replace(NewText, vbLf, "")
        NewText = Replace(NewText, vbCrLf, "")
        NewText = Replace(NewText, "", "")
        RepSymbol = NewText
    End Function
    Public Function RegGet(ByVal OrgText As String, ByVal Pattern As String) As String
    '传递参数 :原字符串, 匹配模式
        Dim Regex As Object
        Dim Mh As Object
        Set Regex = CreateObject("VBScript.RegExp")
        With Regex
            .Global = True
            .Pattern = Pattern
        End With
        If Regex.test(OrgText) Then
            Set Mh = Regex.Execute(OrgText)
            RegGet = Mh.Item(0).submatches(0)
        Else
            RegGet = ""
        End If
        Set Regex = Nothing
    End Function
    

      

  • 相关阅读:
    精简菜单和完整菜单之间进行切换
    QBC运算符含义
    STL源代码剖析——STL算法stl_algo.h
    TI_DSP_corePac_带宽管理
    scrapy-redis源代码分析
    SVG 贝塞尔曲线控制【方便设置】:贝塞尔曲线
    Zoj 2100 Seeding
    快慢指针和链表原地反转
    Gradle 编译多个project(包括多Library库project依赖)指导
    供应商地点信息更新
  • 原文地址:https://www.cnblogs.com/nextseven/p/7574166.html
Copyright © 2011-2022 走看看