【原】「代码」根据关键词，到指定的Word文档中提取句子，学英语的同学可以试一试。

实用案例

|日期控件||简单的收发存||
收费管理系(Access改进版)|

|电子发票管理助手||电子发票登记系统(Access版)|

|文件合并||表格拆分||审计凭证抽查底稿|

|中医诊所收费系统(Excel版)||中医诊所收费系统(Access版)||银行对账单自动勾对|

|印章使用登记系统|

收费使用项目

|财务管理系统||工资薪金和年终奖个税筹划||新税法下工资表模版|

内容提要

• 提取句子|完整代码
  

1、在工作表“关键词”里，命令按钮点击事件，调用提取过程。




Private Sub CmdExtract_Click()    Call extractSentencesEnd Sub

2、在myModule里，自定义过程extractSentences，提取句子：

Option ExplicitSub extractSentences()    Dim wdApp As Object, wdDoc As Object    Dim ws As Worksheet    Dim keyWords As String    Dim i As Long    Dim snt As Object, sentence As String    Dim strText As String    Dim lastRow As Long    Dim startPos As Integer, pos As Integer    Dim quantity As Integer, k As Integer    Dim temp    Dim wordFile As String    Dim IsOpen As Boolean    Application.ScreenUpdating = False    Application.DisplayAlerts = False    temp = Application.InputBox("请输入句子数量:", "输入句子数量", 1)    quantity = Val(temp)    If quantity = 0 Then quantity = 1    Set ws = ThisWorkbook.Sheets("关键词")    On Error Resume Next    Set wdApp = GetObject(, "Word.Application")    If Err.Number <> 0 Then        Set wdApp = CreateObject("Word.Application")    End If    On Error GoTo 0    wordFile = fileSelected    If wordFile = "" Then        MsgBox "请选择一个Word文件！"        Exit Sub    End If    '//判断文档是否打开    IsOpen = False    For i = 1 To wdApp.Documents.Count        If LCase(wdApp.Documents(i).FullName) = LCase(wordFile) Then            Set wdDoc = wdApp.Documents(i)            IsOpen = True            Exit For        End If    Next    '//如果文档未打开，则打开它    If Not IsOpen Then        Set wdDoc = wdApp.Documents.Open(wordFile)    End If    With ws        lastRow = .UsedRange.Rows.Count        .Range(.Cells(2, 3), .Cells(lastRow, 3)).Clear        For i = 2 To lastRow            keyWords = .Cells(i, 2)            If keyWords <> "" Then                strText = ""                k = 1                For Each snt In wdDoc.Range.Sentences                    sentence = Trim(Replace(snt.Text, vbCr, ""))   '清理段落符号                    If InStr(1, sentence, keyWords, vbTextCompare) > 0 Then                        strText = strText & sentence & Chr(10)                        k = k + 1                        If k > quantity Then Exit For                    End If                Next                If strText <> "" Then                    strText = Left(strText, Len(strText) - 1)                End If                .Cells(i, 3).Value = strText                startPos = 1                Do                    pos = InStr(startPos, strText, keyWords, vbTextCompare)                    If pos > 0 Then                        With .Cells(i, 3).Characters(pos, Len(keyWords)).Font                            .Color = vbRed                            .Bold = True                        End With                        startPos = pos + Len(keyWords)                    Else                        Exit Do                    End If                Loop            End If        Next    End With    wdDoc.Close False    If wdApp.Documents.Count = 0 Then        wdApp.Quit    End If    Set wdDoc = Nothing    Set wdApp = Nothing    Application.ScreenUpdating = True    Application.DisplayAlerts = True    MsgBox "完成提取！"End Sub

3、在myModule里，自定义函数fileSelected，选取文件：







Function fileSelected()    With Application.FileDialog(msoFileDialogFilePicker)        .Title = "请选择一个Word文档!"        .Filters.Add "Word文档", "*.doc*"        If .Show = -1 Then            fileSelected = .SelectedItems(1)        Else            Exit Function        End If    End WithEnd Function