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

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

Sub bb()
Dim s$, a$(), i&, L&, Lmax&, Lmin&, mx&, mn&
s = Trim$(InputBox("Введите предложение"))
Debug.Print vbLf; ">>> Исходное:"; vbLf; s
a = Split(Trim$(s))
Lmin = Len(a(0))
Lmax = Lmin
For i = 1 To UBound(a)
    L = Len(a(i))
    If L Then
        If L > Lmax Then
            Lmax = L: mx = i
        ElseIf L < Lmin Then
            Lmin = L: mn = i
        End If
    End If
Next
s = a(mx)
a(mx) = a(mn)
a(mn) = s
Debug.Print vbLf; ">>> Результат:"; vbLf; Join(a)
End Sub