zoukankan      html  css  js  c++  java
  • 20170706wdVBA正则表达式提取题目

    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*?((?:[^
    ]*?d+题[^
    ]?s*?[^
    ]*?s*?)?d*[.,、.](?:[^
    ]*?
    ?[
    ]+?){1,4}?)s*?" & _
                       "(A[.,、.].*?)s+?" & _
                       "(B[.,、 .].*?)s+?" & _
                       "(C[.,、.].*?)s+?" & _
                       "(D[.,、.].*?)s*?" & "
    ?[
    ]+"
            .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
    

      

  • 相关阅读:
    poj 3321 Apple Tree
    hdu 1520 Anniversary party
    Light OJ 1089 Points in Segments (II)
    Timus 1018 Binary Apple Tree
    zoj 3299 Fall the Brick
    HFUT 1287 法默尔的农场
    Codeforces 159C String Manipulation 1.0
    GraphQL + React Apollo + React Hook 大型项目实战(32 个视频)
    使用 TypeScript & mocha & chai 写测试代码实战(17 个视频)
    GraphQL + React Apollo + React Hook + Express + Mongodb 大型前后端分离项目实战之后端(19 个视频)
  • 原文地址:https://www.cnblogs.com/nextseven/p/7129066.html
Copyright © 2011-2022 走看看