先日、「【コード】文書に含まれる単語を調べるマクロ_並べ替え付き(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