Private Sub ShellSort(ByRef this() As String)
Dim idFirst As Long, idLast As Long, tmp As String
Dim Stepping As Long, i As Long, pos As Long
idFirst = LBound(this): idLast = UBound(this)
Stepping = 1: pos = idLast - idFirst + 1
For i = 1 To pos
Stepping = 3& * Stepping + 1
If Stepping > pos Then Exit For
Next
Do
Stepping = Stepping \ 3&
For i = (Stepping + 1) To idLast
pos = i: tmp = this(i)
Do While (this(pos - Stepping) > tmp)
this(pos) = this(pos - Stepping)
pos = pos - Stepping
If (pos - Stepping) < 1 Then Exit Do
Loop
this(pos) = tmp
Next i
Loop Until Stepping = 1
End Sub
Public Sub CreateUnique()
Dim pReg As Object, pDict As Object, sText As String
Dim subStr() As String, i As Long, pDoc As Document
Set pReg = CreateObject("VBScript.RegExp")
pReg.Global = True: pReg.IgnoreCase = True
'настройка, что есть слово - всё остальное разделители
pReg.Pattern = "[^0-9a-zа-я]"
sText = Application.ActiveDocument.Range.Text
sText = pReg.Replace(sText, " ")
pReg.Pattern = "[ ]+"
sText = pReg.Replace(sText, " ")
Set pDict = CreateObject("Scripting.Dictionary")
pDict.CompareMode = 1: subStr = VBA.Split(sText, " ")
For i = LBound(subStr) To UBound(subStr)
pDict(subStr(i)) = subStr(i)
Next i
subStr = VBA.Split(VBA.Join(pDict.Keys, " "), " ")
ShellSort subStr
Set pDoc = Application.Documents.Add
pDoc.Range.Text = VBA.Join(subStr, vbCr)
End Sub
|
