【コード】文書に含まれる単語を調べるマクロ_並べ替え付き(Collectionオブジェクト)(その2)

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

トップへ戻る