Oscar Sun

                  Option Explicit
Dim cnt As New ADODB.Connection
Dim rst As New ADODB.Recordset


Sub 書名號篇名號檢查() '2017/3/2
Dim s As Long, rng As Range, e, trm As String, ans
Static x() As String, i As Integer
Const strFD As String = "篇名號檢查" '校對用資料表
Const strPath As String = "E:\黃老師工作_守真\tools" '校對用資料庫所在路徑
On Error GoTo eH
Do
    If Selection.Find.Execute("〈", , , , , , True, wdFindStop) = False Then MsgBox "done!", vbInformation: GoTo 3
    Set rng = Selection.Range
    rng.MoveEndUntil "〉"
    trm = Mid(rng, 2)
    
    For Each e In x()
        If StrComp(e, trm) = 0 Then GoTo 1
    Next e
2   ans = MsgBox("是否略過「" & trm & "」？" & vbCr & vbCr & vbCr & "結束請按 NO[否]", vbExclamation + vbYesNoCancel)
    Select Case ans
        Case vbYes
            ReDim Preserve x(i) As String
            x(i) = trm
            i = i + 1
        Case vbNo
3
            For Each e In x()
                If rst.State = adStateOpen Then rst.Close
                rst.Open "select * from " & strFD & " where strcomp(可略去關鍵字,""" & e & """)=0 ", cnt, adOpenKeyset, adLockOptimistic
                If rst.RecordCount = 0 Then
                    rst.AddNew
                    rst.Fields(1).Value = e
                    rst.Update
                End If
            Next e
            Exit Sub
    End Select
1
Loop
Exit Sub
eH:
Select Case Err.Number
    Case 92 '沒有設定 For 迴圈的初始值 陣列尚未有值
        cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & strPath & "校對用資料庫.accdb"
        rst.Open "SELECT Len([可略去關鍵字]) AS Expr1, * FROM " & strFD & " ORDER BY Len([可略去關鍵字]) DESC", cnt, adOpenKeyset, adLockOptimistic
        With rst
            Do Until .EOF
                ReDim Preserve x(CLng(rst.AbsolutePosition) - 1) As String
                x(CLng(rst.AbsolutePosition) - 1) = rst.Fields(2).Value
                .MoveNext
                i = i + 1
            Loop
        End With
        GoTo 2
End Select
End Sub