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
    

      

  • 相关阅读:
    六:Vue之父子组件间的三种通信方式
    五:Vue之ElementUI 表格Table与分页Pagination组件化
    四:Vue之VUEX状态管理
    三:Vue之混入(mixin)与全局混入
    二:Vue之ElementUI Form表单校验
    一:Vue之开发环境搭建
    变了,说不出来的感觉。
    20180320作业2:进行代码复审训练
    20180320作业1:源代码管理工具调查
    15软工课后作业02-15100120
  • 原文地址:https://www.cnblogs.com/nextseven/p/7227702.html
Copyright © 2011-2022 走看看