Sub Antiplagiat()
Dim oRng As Range, i&, IsEnd As Boolean
Dim iStart& 'Переменная для ограничения нижней границы поиска
Do While Not IsEnd 'Продолжаем поиск пока флаг установлен
With ActiveDocument.Range(iStart, ActiveDocument.Range.End).Find 'Ищем слово, которое может состоять только из латинских или кириллических букв
.Text = "<[A-za-zА-ЯЁа-яё]@>"
.MatchWildcards = True
.Execute
If .Found Then 'слово найдено
Set oRng = .Parent 'Найденная часть документа
'----------------------------------------------------
If Len(oRng.Text) <= 8 And Len(oRng.Text) > 1 Then
oRng.Characters(oRng.Characters.Count \ 2).InsertAfter " "
ElseIf Len(oRng.Text) > 8 Then
oRng.Characters(oRng.Characters.Count \ 3).InsertAfter " "
oRng.Characters(oRng.Characters.Count * 2 \ 3).InsertAfter " "
End If
'----------------------------------------------------
'Перед каждым символом в слове, кроме первого, вставляем пробел
For i = oRng.Characters.Count To 2 Step -1
oRng.Characters(i).InsertBefore " "
Next
'Нижнюю границу поиска переносим в конец слова уже с учетом добавленных пробелов
iStart = oRng.End
'В слове, разделенном пробелами делаем величину шрифта для пробелов равной 1
With oRng.Find .Text = " "
.Replacement.Font.Size = 1
.Execute Replace:=wdReplaceAll
End With Else: IsEnd = True
'Если слово не было найдено, выходим из цикла
End If
End With
Loop
End Sub

Sub AntiPlagiat1()
With ActiveDocument.Range
.Find .Text = "([A-Za-zА-Яа-яЁё])([A-Za-zА-Яа-яЁё])": .MatchWildcards = True
.Replacement.Text = "\1#$&@\2" .Execute Replace:=wdReplaceAll
.Text = "#$&@": .MatchWildcards = False
.Replacement.Text = " ": .Replacement.Font.Size = 1
.Execute Replace:=wdReplaceAll
End With
End Sub

Sub antiplagiat2()
Dim oRng As Range, i&, IsEnd As Boolean
Dim iStart&
Do While Not IsEnd
With ActiveDocument.Range(iStart, ActiveDocument.Range.End).Find
.Text = "<[а-я]@>" .MatchWildcards = True
.Execute
If .Found Then Set oRng = .Parent
If Len(oRng.Text) > 8 Then
oRng.Characters(7).InsertAfter ChrW(1072) 'Ну или любой другой
With oRng.Characters(8)
.Font.Size = 1
End With
End If
iStart = oRng.End
Else: IsEnd = True
End If
End With
Loop
Selection.WholeStory
Selection.LanguageID = wdRussian
Selection.NoProofing = True
Application.CheckLanguage = True
End Sub