20170706wdVBA正则表达式提取题目

最新推荐文章于 2025-02-07 08:53:35 发布

weixin_30426957

最新推荐文章于 2025-02-07 08:53:35 发布

阅读量192

点赞数

CC 4.0 BY-SA版权

原文链接：http://www.cnblogs.com/nextseven/p/7129066.html

本文介绍了一个使用VBA编写的程序，该程序能够从Word文档中提取特定格式的选择题题目及其选项，并将这些信息整理后保存到Excel工作簿中。此程序适用于批量处理教育资料，提高教师工作效率。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

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

转载于:https://www.cnblogs.com/nextseven/p/7129066.html