【Word VBA】文書に含まれる単語を調べるマクロ_並べ替え付き（Collectionオブジェクト）（その2）

2019年11月24日

, ,

先日、「【コード】文書に含まれる単語を調べるマクロ_並べ替え付き（Collectionオブジェクト）」にコメントをいただきまして、アルファベット順に高速で並べ替える方法（マージソート）を教えていただきました。焼き畑さん、どうもありがとうございます！

せっかくなので埋もれないように記事にさせていただきました。文書中の単語を並べ替えます。

このマクロでできること

「【コード】文書に含まれる単語を調べるマクロ_並べ替え付き（Collectionオブジェクト）」と同じことができます。処理対象の文書中の単語（Wordが識別する単語という意味です。和文でも単語が切り出されます）を抽出して並べ替えます。

マクロの解説

28行目以降に今回教えていただいたマージソート（msortというプロシージャー名）が書かれています。教えていただいたコードのインデントと改行だけ変えて、内容はそのまま使わせていただきました。

マクロ


Sub 文書に含まれる単語を書き出すマクロ_並べ替え_高速()

　'大文字・小文字の区別をしない
　'全角・半角の区別をしない

　Dim myDic As New Collection
　Dim wrd As Range
　Dim myItem As Variant
　
　On Error Resume Next
　For Each wrd In ActiveDocument.Words
　　myDic.Add Item:=wrd.Text, Key:=CStr(wrd.Text)
　Next wrd
　On Error GoTo 0
　
　'ソートをする
　Set myDic = msort(myDic)

　'書き出し
　With Application.Documents.Add
　　For Each myItem In myDic
　　　.Range.InsertAfter myItem & vbCr
　　Next myItem
　End With
　
End Sub

Function msort(c As Collection) As Collection

　Dim cL1 As New Collection
　Dim cL2 As New Collection
　Dim cr1 As New Collection
　Dim cr2 As New Collection
　Dim resC As New Collection
　Dim m As Long
　Dim m2 As Long
　Dim i
　Dim lp, rp, p
　Dim lmax, rmax
　
　m = c.Count
　
　If m = 0 Then
　　'何もしない
　ElseIf m = 1 Then
　　resC.Add c(1)
　Else
　　m = m - 1
　　m2 = m \ 2
　　p = 1
　　
　　For i = 0 To m2
　　　cL1.Add c(i + 1)
　　Next
　　
　　p = 1
　　
　　For i = m2 + 1 To m
　　　cr1.Add c(i + 1)
　　Next
　　
　　Set cL2 = msort(cL1)
　　Set cr2 = msort(cr1)
　　lmax = cL2.Count
　　rmax = cr2.Count
　　lp = 1
　　rp = 1
　　
　　While lp <= lmax Or rp <= rmax
　　　
　　　If lp > lmax Then
　　　　resC.Add cr2(rp)
　　　　rp = rp + 1
　　　ElseIf rp > rmax Then
　　　　resC.Add cL2(lp)
　　　　lp = lp + 1
　　　Else
　　　　If cL2(lp) > cr2(rp) Then
　　　　　resC.Add cr2(rp)
　　　　　rp = rp + 1
　　　　Else
　　　　　resC.Add cL2(lp)
　　　　　lp = lp + 1
　　　　End If
　　　End If
　　　
　　　p = p + 1
　　
　　Wend
　
　End If
　
　Set cL1 = Nothing
　Set cL2 = Nothing
　Set cr1 = Nothing
　Set cr2 = Nothing
　Set msort = resC

End Function

-コード
-, ,