码迷,mamicode.com
首页 > 编程语言 > 详细

wdVBA正则表达式提取题目

时间:2017-07-07 00:47:21      阅读:270      评论:0      收藏:0      [点我收藏+]

标签:wrap   one   end   quit   alignment   pattern   文件   选择   log   

Public Sub GetContents()
    Dim Reg As Object
    Dim Matches As Object
    Dim OneMatch As Object
    Dim Index As Long
    Dim TimeStart As Variant
    TimeStart = VBA.Timer
    Set Reg = CreateObject("Vbscript.RegExp")
    With Reg
        .Pattern = "^\s*?((?:[^\r]*?\d+题[^\r]?\s*?[^\r]*?\s*?)?\d*[\.,、.](?:[^\r\n]*?\r?[\r\n]+?){1,4}?)\s*?" & _
                   "(A[\.,、.].*?)\s+?" & _
                   "(B[\.,、 .].*?)\s+?" & _
                   "(C[\.,、.].*?)\s+?" & _
                   "(D[\.,、.].*?)\s*?" & "\r?[\r\n]+"
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
    End With

    Dim FilePath As String
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .InitialFileName = ActiveDocument.Path
        .Title = "请选择单个Excel工作簿"
        .Filters.Clear
        .Filters.Add "Excel工作簿", "*.xls*"
        If .Show = -1 Then
            FilePath = .SelectedItems(1)
        Else
            MsgBox "您没有选中任何文件夹,本次汇总中断!"
            Exit Sub
        End If
    End With

    Dim xlApp As Object
    Dim wb As Object
    Dim sht As Object
    Dim StartRow As Long
    Dim StartIndex As Long

    Set xlApp = CreateObject("Excel.Application")
    Set wb = xlApp.workbooks.Open(FilePath)
    Set sht = wb.worksheets.Add(After:=wb.worksheets(wb.worksheets.Count))
    sht.Name = "提取记录" & wb.worksheets.Count - 1
    sht.Range("A1:H1").Value = Array("储存序号", "引言题干", "A选项", "B选项", "C选项", "D选项", "正确答案", "配图名称")

    With sht
        StartRow = .Range("A65536").End(3).Row
        StartIndex = StartRow - 1

        Set Matches = Reg.Execute(ActiveDocument.Content.Text)
        Index = 0
        For Each OneMatch In Matches
            Index = Index + 1
            ‘‘Debug.Print "Question Index  " & N & "   :   " ‘; OneMatch
            For i = 0 To OneMatch.submatches.Count - 1
                .Cells(StartRow + Index, 1).Value = StartIndex + Index
                .Cells(StartRow + Index, 2).Value = OneMatch.submatches(0)
                .Cells(StartRow + Index, 3).Value = OneMatch.submatches(1)
                .Cells(StartRow + Index, 4).Value = OneMatch.submatches(2)
                .Cells(StartRow + Index, 5).Value = OneMatch.submatches(3)
                .Cells(StartRow + Index, 6).Value = OneMatch.submatches(4)
                ‘If i <> 0 Then
                ‘Debug.Print ">>>>Option Index"; i; "  :   "; OneMatch.submatches(i)
                ‘Else
                ‘  Debug.Print ">>>>Question Index  0 "; "  :   "; OneMatch.submatches(i)
                ‘ End If
            Next i
            ‘ If N = 17 Then Exit For
        Next

        With .usedrange
            .HorizontalAlignment = xlGeneral
            .VerticalAlignment = xlCenter
            .WrapText = True
        End With

        If ShowPicName Then xlApp.WorksheetFunction.Transpose (PicName)

        .usedrange.Columns.AutoFit
    End With


    wb.Close True
    xlApp.Quit
    Set sht = Nothing
    Set wb = Nothing
    Set xlApp = Nothing

    Debug.Print VBA.Timer - TimeStart; "秒"
    Set Reg = Nothing
End Sub

  

wdVBA正则表达式提取题目

标签:wrap   one   end   quit   alignment   pattern   文件   选择   log   

原文地址:http://www.cnblogs.com/nextseven/p/7129066.html

(0)
(0)
   
举报
评论 一句话评论(0
登录后才能评论!
© 2014 mamicode.com 版权所有  联系我们:gaon5@hotmail.com
迷上了代码!