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
    

      

  • 相关阅读:
    c++ ShellExecuteEx调用java打包的exe程序
    麻省理工学院公开课-第四讲:快速排序 及 随机化 算法
    Win10的IIS与以前版本的一个区别
    干就行了!!!写程序就像珊瑚,分支太多,哪有那么多复用!
    NPoco的使用方法
    为什么前端要写标准代码?
    对于委托、事件、观察者模式最一目了然的代码段
    delphi处理消息的几种方式
    哎呀妈呀,吓死我了,幸好服务器没崩溃。
    Delphi的Hint介绍以及用其重写气泡提示以达到好看的效果
  • 原文地址:https://www.cnblogs.com/nextseven/p/7227702.html
Copyright © 2011-2022 走看看