比對說文資料庫之資料.bas 

                  Sub AddReference()
On Error Resume Next
With Application.VBE.ActiveVBProject.References
    .AddFromFile "C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB"
    .AddFromFile "c:\program files\microsoft office\office14\msword.olb"
End With
'http://www.mrexcel.com/forum/excel-questions/590567-use-visual-basic-applications-install-excel-reference.html
''http://support.microsoft.com/kb/308340/zh-tw
'   Dim vbProj As VBProject
'
'   Set vbProj = ActiveWorkbook.VBProject
'   'vbProj.References.AddFromFile "C:\TestFiles\Refme.dot"
'   vbProj.References.AddFromFile "c:\program files\microsoft office\office14\msword.olb"
''按一下 [工具] 功能表上的 [設定引用項目]，然後將參考加入 Microsoft Visual Basic for Applications Extensibility 5.3 程式庫中。此程式庫包含參考 VBA 專案的物件。
''"C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6"
End Sub

Sub 比對說文資料庫之資料()
Dim D As Document, P As Paragraph, S As Worksheet
Set S = ActiveSheet
If D Is Nothing Then Set D = Word.Application.ActiveDocument
i = 1: J = 1
With D
    For Each P In D.Paragraphs
        If P.Range.Characters(1) = "0" Then
            Do Until StrComp(P.Range.Characters(i), "（") = 0
                i = i + 1
            Loop
            x = P.Range.Characters(i + 1)
            TXT = P.Range
            ID = Val(Mid(TXT, 1, InStr(1, TXT, "　", vbTextCompare)))
            
            With S
                Do Until .Cells(J, "C") = ID '含重文序號
                    J = J + 1
                Loop
                If StrComp(x, .Cells(J, "k")) <> 0 Then '楷體
                    .Cells(J, "k").Select
                    P.Range.Select
                    AppActivate "MICROSOFT EXCEL"
                    'Stop
                    If MsgBox("是否增補此字？", vbQuestion + vbOKCancel) = vbCancel Then
                        GoTo 1
                    Else
    '                   .Rows(J).Select
    '                   Selection.Insert Shift:=xlDown ', CopyOrigin:=xlFormatFromLeftOrAbove
                        '.Cells(J, 2).Activate
                        Application.CutCopyMode = False
                        .Rows(J).Insert 'Shift:=xlDown
                        .Rows(J).Select
                        With Selection.Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .Color = 65535
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                       .Cells(J, 2) = .Cells(J - 1, 2)
                       .Cells(J, 2).Font.Color = RGB(255, 0, 0)
                       .Cells(J - 1, 2).Font.Color = RGB(255, 0, 0)
                       .Cells(J, 3) = .Cells(J - 1, 3) + 1
                       .Cells(J, 4) = .Cells(J - 1, 4)
                       .Cells(J, 7) = .Cells(J - 1, 7) 'G
                       .Cells(J, 8) = .Cells(J - 1, 8) 'H
                       .Cells(J, 9) = .Cells(J - 1, 9) 'I
                       .Cells(J, "i").Font.Color = RGB(255, 0, 0)
                       .Cells(J - 1, "i").Font.Color = RGB(255, 0, 0)
                       .Cells(J, 10) = .Cells(J - 1, 10) 'J
                       .Cells(J, "j").Font.Color = RGB(255, 0, 0)
                       .Cells(J - 1, "j").Font.Color = RGB(255, 0, 0)
                       .Cells(J, 11) = x 'K
                       .Cells(J, 11).Font.Color = RGB(255, 0, 0)
                       .Cells(J, 12) = x
                       .Cells(J, 12).Font.Color = RGB(255, 0, 0)
                       .Cells(J, 13) = x 'M
                       .Cells(J, 13).Font.Color = RGB(255, 0, 0)
                       .Cells(J, "o") = Mid(TXT, InStr(1, TXT, "，", vbTextCompare) + 1, InStr(InStr(1, TXT, "，", vbTextCompare), TXT, "（", vbTextCompare) - InStr(1, TXT, "，", vbTextCompare) - 1)
                       .Cells(J, "p") = .Cells(J - 1, "p") '反切
                       .Cells(J, "p").Font.Color = RGB(255, 0, 0)
                       .Cells(J, "R") = .Cells(J - 1, "R")
                       .Cells(J, "s") = .Cells(J - 1, "s")
                       .Cells(J, "v") = "補。原書無反切"
                       q = J
                       Do Until .Cells(q + 1, 3) = "" '含重文序號,自動填滿
                            .Cells(q + 1, 3) = .Cells(q, 3) + 1
                            q = q + 1
                       Loop
                       'Stop
                   End If
1               Stop
                End If
            End With
        End If
        i = 1
        J = 1
    Next P
End With


End Sub
View Oscar's Profile