zoukankan      html  css  js  c++  java
  • 20170724wdVBA正则表达式提取答案到Excel

    Public Sub RegExtractData()
        Dim StartTime, UsedTime
        StartTime = VBA.Timer
    
        Dim FilePath$
        Dim FileName$
        Dim doc As Document
        Dim Arr() As String
        Dim ExamNo As String
        Dim Index As Long
        Dim Count As Long
    
        Dim xlApp As Object    'Excel.Application
        Dim wb As Object    'Excel.Workbook
        Dim sht As Object    'Excel.Worksheet
        Dim Reg As Object, Mh As Object, OneMh As Object
        Set Reg = CreateObject("Vbscript.Regexp")
        With Reg
            .MultiLine = True
            .Global = True
            .Ignorecase = False
        End With
    
        Application.ScreenUpdating = False
        Application.DisplayAlerts = wdAlertsNone
    
        FilePath = ThisDocument.Path & "试卷"
        FileName = Dir(FilePath & "*.doc*")
    
        Count = 0
        ReDim Arr(1 To 3, 1 To 1)
    
        Do While FileName <> ""
            Debug.Print FilePath & FileName
            Set doc = Application.Documents.Open(FilePath & FileName)
            Index = 0
            Content = doc.Content.Text
    
            '试卷编号:0199
            Reg.Pattern = "(?:试卷编号:)(S+?)(?:[s]+?)"
            Set Mh = Reg.Execute(Content)
            ExamNo = "'" & Mh.Item(0).submatches(0)
            Debug.Print ExamNo
    
            '答案:A|B|C
            Reg.Pattern = "(?:答案:)(S+?)(?:[s]+?)"
            Set Mh = Reg.Execute(Content)
            For Each OneMh In Mh
                Index = Index + 1
                Count = Count + 1
                ReDim Preserve Arr(1 To 3, 1 To Count)
                Arr(1, Count) = ExamNo
                Arr(2, Count) = Index
                Arr(3, Count) = OneMh.submatches(0)
            Next OneMh
    
            doc.Close
            FileName = Dir
        Loop
    
        Set Reg = Nothing
    
        Application.ScreenUpdating = True
        Application.DisplayAlerts = wdAlertsAll
    
        Set xlApp = CreateObject("Excel.Application")    'Excel.Application
        With xlApp
            Set wb = xlApp.Workbooks.Add   'Open(ThisDocument.Path & "" & "答案模板.xls")
            With wb
                Set sht = .Worksheets("Sheet1")
                With sht
                    .Range("A1:C1").Value = Array("试卷编号", "题号", "答案")
                    .Range("A2").Resize(Count, 3).Value = xlApp.WorksheetFunction.Transpose(Arr)
                End With
                'xlApp.WorksheetFunction.Transpose (Arr)
                .SaveAs ThisDocument.Path & "" & Format(Now(), "yyyymmdd-hhmm") & "-答案.xls"
                .Close True
            End With
            .Quit
        End With
    
        Set xlApp = Nothing
        Set wb = Nothing
        Set sht = Nothing
        UsedTime = VBA.Timer - StartTime
        MsgBox "提取完成!用时" & Format(UsedTime, "0.00 秒。")
    
    End Sub
    

      

  • 相关阅读:
    linux中的umask命令
    The meaning of the number displayed on the man page in Linux
    Runlevel in Linux
    C语言指针与指向指针的指针
    JS函数、变量作用域
    JS对象、数据类型区别、函数
    JavaScript基础
    DOM
    HTML色码表
    GIT
  • 原文地址:https://www.cnblogs.com/nextseven/p/7227702.html
Copyright © 2011-2022 走看看