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
    

      

  • 相关阅读:
    HDU 1251 统计难题 字符匹配
    mac 安装mysql
    ubuntu git 下添加 ssh
    mac下virtualenv使用
    git-ssh配置和使用
    在PythonAnyWhere上部署Django项目
    ImportError: No module named PIL
    mysql 命令行操作
    ubuntu安装ssh
    常用git命令
  • 原文地址:https://www.cnblogs.com/nextseven/p/7227702.html
Copyright © 2011-2022 走看看