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
    

      

  • 相关阅读:
    调用系统地图进行导航
    ShareSDK使用简介
    FMDB
    关于uitableView的Group模式滑动偏移问题
    iOS GCD详解
    通知中心传值
    开源 iOS 项目分类索引大全
    iOS10隐私设置及相应问题
    支付
    OC中如何把字典中的数据拼接成url字符串
  • 原文地址:https://www.cnblogs.com/nextseven/p/7227702.html
Copyright © 2011-2022 走看看