Переставить местами слова с максимальной и минимальной длиной - VBA - Ответ 2236959

Sub SwapFirstTheLongestAndTheShortest()
'переставляет те первые слова в предложении Word, длина которых равна max и min
Dim min As Integer, minN As Integer, max As Integer, maxN As Integer
Dim N As Integer, minF As Integer, maxF As Integer, strWord As String
 
        max = 1:    maxF = 1    'задали максимум, покрывающий все вообразимые слова
        min = 100:  minF = 100  'так же и с минимумом: делаем его изначально большим
    
    With ActiveDocument.Sentences.First.Words   'работаем со словами 1-го предложения
        For N = 1 To .Count 'просматриваем слова с первого по последнее
        .Item(N).Select     'выделили N-е; но нас интересуют настоящие слова, из букв
        If Right(Selection, 1) = " " Then Selection.MoveLeft Extend:=wdExtend
                                'сняли выделение с правого пробела (это граница слова)
        minN = Len(Selection)
        If minN = 1 Then
            If Left(.Item(N), 1) Like "[A-zА-яЁё]" Then
                'выходим из цикла, если N-е слово состоит из 1 буквы - оно минимально
                min = 1: minF = N: Exit For
            Else
                GoTo NextN
            End If
        End If
        If minN < min Then min = minN: minF = N 'нашли (первый) минимум и номер слова
NextN:
        Next
                        MsgBox .Item(minF).Text, vbInformation, "1-е минимальное слово"
                        
        For N = 1 To .Count 'опять просматриваем слова - ищем первое максимальное
        .Item(N).Select
        If Right(Selection, 1) = " " Then Selection.MoveLeft Extend:=wdExtend
                                'сняли выделение с правого пробела (это граница слова)
        maxN = Len(Selection)
        If maxN > max Then max = maxN: maxF = N 'нашли (первый) максимум и номер слова
        Next
                        MsgBox .Item(maxF).Text, vbInformation, "1-е максимальное слово"
                        
        strWord = .Item(minF): .Item(minF) = .Item(maxF) & " ": .Item(maxF) = strWord
        'здесь можно ещё убрать лишние пробелы, но это уже слишком
    End With
End Sub