列出漢字部件數及其部件；可以將選取的漢字詞句，其部件總數及部件列出（會汰重） Word VBA

Option Explicit Dim docx As Document Sub 查詢部件字頻() Shell SearchPath & "\!!!!部件4要檔!!!!\部件篩選器.exe", vbNormalFocus End Sub Function 某詞部件數查詢(rng As Range, ByRef r() As Range) As Integer Dim a, n As Integer, zi As Integer If rng.Characters.Count < 2 Then Exit Function For Each a In rng.Characters n = n + CInt(某字部件數查詢(VBA.CStr(a), zi, r)) zi = zi + 1 Next a 某詞部件數查詢 = n End Function Function 某字部件數查詢(w As String, ByVal zi As Integer, ByRef copyRng() As Range) As Byte Static wArray() ', wd As String Dim c As Cell, flg As Boolean, rng As Range, r As Integer, s As Integer If docx Is Nothing Then Set docx = GetObject(system.SearchPath & "\!!!!部件4要檔!!!!\4808字之部件new.docm") For Each c In docx.Tables(1).Columns(1).Cells r = r + 1 If r > 1 Then ' wd = wd & VBA.Replace(c.Range.Text, Chr(13) & Chr(7), "") ReDim Preserve wArray(r - 2) wArray(r - 2) = c.Range.Characters(1) End If Next c r = 0 With docx.ActiveWindow .WindowState = wdWindowStateMinimize .Visible = True End With End If 's = VBA.InStr(wd, w) s = UBound(wArray) For r = 0 To s If StrComp(wArray(r), w) = 0 Then s = r + 1 r = 0 Exit For End If Next If r = s + 1 Then '找不到 ' If VBA.InStr(Str.所有符號(), w) Then ' 'stay no processing ' End If s = 0 r = 0 End If If s > 0 Then ' For Each c In docx.Tables(1).Columns(1).Cells'this had poor performance ' r = r + 1 ' If r > 1 Then ' If VBA.InStr(c.Range.Text, w) Then Set c = docx.Tables(1).Cell(s + 1, 1) 某字部件數查詢 = VBA.CByte(VBA.Replace(c.Next.Next.Range.Text, Chr(13) & Chr(7), "")) Set rng = c.Next.Next.Range rng.SetRange c.Next.Range.Start, c.Next.Range.End - 1 Set copyRng(zi) = rng flg = True ' Exit For ' End If ' End If ' Next End If If flg = False Then ' MsgBox "沒有找到", vbExclamation 'Debug.Print w 某字部件數查詢 = 0 End If End Function Sub 某字部件數列出() Dim w As String, wCnt As Integer, cnt As Integer 'Alt+s. Alt+q Dim rng As Range, deleteTimes As Integer Application.ScreenUpdating = False w = Selection.Text Set rng = Selection.Range If Selection.Type <> wdSelectionIP Then Selection.Collapse wdCollapseEnd Else Selection.Move wdCharacter, 1 End If If VBA.InStr(Str.所有符號(), w) > 0 Then Exit Sub '符號字不處理 wCnt = rng.Characters.Count ReDim r(wCnt - 1) As Range If wCnt > 1 Then cnt = 某詞部件數查詢(rng, r) Else cnt = VBA.CInt(VBA.CStr(某字部件數查詢(w, 0, r))) End If If cnt > 0 Then If wCnt = 1 Then Selection.TypeText VBA.CStr(cnt) Selection.ParagraphFormat.BaseLineAlignment = wdBaselineAlignCenter If wCnt > 1 Then 'remark the position before paste Dim rg As Range, rgNext As Range, stRg As Long, a, b stRg = Selection.End End If 某字部件列出 r If wCnt > 1 Then Set rg = Selection.Document.Range(Start:=stRg, End:=Selection.End) Set rgNext = Selection.Document.Range(rg.Characters(2).Start, rg.End) '取得了range陣列貼上後,要汰重 eliminate duplicates For Each a In rg.Characters rgNext.SetRange a.Next.Start, rg.End For Each b In rgNext.Characters If a.InlineShapes.Count = 0 Then If b = a Then b.Delete End If Else If b.InlineShapes.Count > 0 Then If b.InlineShapes(1).AlternativeText = a.InlineShapes(1).AlternativeText Then b.Delete End If End If Next b Next a wCnt = rg.Characters.Count rg.SetRange Start:=stRg, End:=stRg rg.InsertAfter VBA.CStr(wCnt) End If Else MsgBox "尚無「" & w & "」字部件!", vbExclamation End If Application.ScreenUpdating = True End Sub Sub 某字部件列出(r() As Range) Dim e On Error GoTo quz Set e = r(0) For Each e In r If Not e Is Nothing Then '若找不到部件則是nothing e.Copy Selection.Paste End If Next e quz: End Sub Sub 部件數大於多少之字列出() Dim rng As Range, a, n, z As Byte, docx As Document, sybol As String, r(1) As Range Set rng = Selection.Range n = InputBox("請輸入要多過多少個部件數的字才列出？", , "2") If n = "" Then Exit Sub If Not VBA.IsNumeric(n) Then Exit Sub n = VBA.CByte(n) sybol = Str.所有符號 For Each a In rng.Characters If VBA.InStr(sybol, a) = 0 Then '符號字不處理 z = 某字部件數查詢(VBA.CStr(a), 0, r) If z > n Then If docx Is Nothing Then Set docx = Documents.Add docx.Range.InsertAfter a ElseIf z = 0 Then '找不到 docx.ActiveWindow.Selection.HomeKey wdStory, wdMove docx.ActiveWindow.Selection.TypeText a docx.ActiveWindow.Selection.MoveLeft wdCharacter, 1, wdExtend Selection.Font.ColorIndex = wdRed End If End If Next End Sub