Эту задачу я решил по вашему же запросу на киберфоруме. Копирую ответ сюда
Option Explicit
Public Type HyphenPair
Pattern As String
Position As Integer
End Type
Dim arHPairs(12) As HyphenPair
Private Const x As String = "йьъ"
Private Const g As String = "аеёиоуыэюяaeiouy"
Private Const s As String = "бвгджзклмнпрстфхцчшщbcdfghjklmnpqrstvwxz"
Sub HyphenateEveryThirdWord()
Dim arHyphPos As Variant
Dim oRng As Range, nHyphPos As Integer
Dim sText As String
On Error GoTo HyphenateEveryThirdWord_Error
Set oRng = ActiveDocument.Words.First
Dim i As Integer
i = 1
Do Until oRng Is Nothing
If Len(Trim(oRng.text)) > 0 Then
arHyphPos = HyphenPositions(Trim(oRng.text))
Randomize
'Случайная позиция вставки переноса
nHyphPos = Int((UBound(arHyphPos) - 1) * Rnd)
nHyphPos = arHyphPos(nHyphPos)
oRng.text = Mid(oRng.text, 1, nHyphPos) & ChrW(31) & Mid(oRng.text, nHyphPos + 1)
i = i + 3
Set oRng = ActiveDocument.Words(i)
DoEvents
End If
Loop
On Error GoTo 0
Exit Sub
HyphenateEveryThirdWord_Error:
End Sub
'Номера символов после которых можно вставить переносы
Public Function HyphenPositions(text As String) As Variant
Dim i As Integer, j As Integer
Dim sb As String, sText As String
Dim retval As String
sText = StrConv(text, vbLowerCase)
Call Main
For i = 1 To Len(sText)
If InStr(x, Mid(sText, i, 1)) <> 0 Then
sb = sb & "x"
ElseIf InStr(g, Mid(sText, i, 1)) <> 0 Then
sb = sb & "g"
ElseIf InStr(s, Mid(sText, i, 1)) <> 0 Then
sb = sb & "s"
End If
Next
Dim hp As HyphenPair, index As Integer, actualindex As Integer
For i = 0 To UBound(arHPairs)
hp = arHPairs(i)
index = InStr(sb, hp.Pattern)
While (index <> 0)
actualindex = index + hp.Position
retval = retval & actualindex - 1 - j & ","
sb = Mid(sb, 1, actualindex - 1) & "-" & Mid(sb, actualindex)
index = InStr(sb, hp.Pattern)
j = j + 1 'Счётчик вставленных переносов
Wend
Next i
retval = Mid(retval, 1, Len(retval) - 1)
HyphenPositions = Split(retval, ",")
End Function
Sub Main()
Dim hp As HyphenPair
arHPairs(0).Pattern = "xgg": arHPairs(0).Position = 1
arHPairs(1).Pattern = "xgs": arHPairs(1).Position = 1
arHPairs(2).Pattern = "xsg": arHPairs(2).Position = 1
arHPairs(3).Pattern = "xss": arHPairs(3).Position = 1
arHPairs(4).Pattern = "gsg": arHPairs(4).Position = 1
arHPairs(5).Pattern = "sgg": arHPairs(5).Position = 2
arHPairs(6).Pattern = "gssssg": arHPairs(6).Position = 3
arHPairs(7).Pattern = "gsssg": arHPairs(7).Position = 3
arHPairs(8).Pattern = "gsssg": arHPairs(8).Position = 2
arHPairs(9).Pattern = "gssg": arHPairs(9).Position = 2
arHPairs(10).Pattern = "sgsg": arHPairs(10).Position = 2
arHPairs(11).Pattern = "sggg": arHPairs(11).Position = 2
arHPairs(12).Pattern = "sggs": arHPairs(12).Position = 2
End Sub
Вызывать процедуру HyphenateEveryThirdWord. Неочевидно, но разбивка на слоги и расстановка переносов — не совсем одно и то же. Предложенный макрос работает корректно с подавляющим большинством слов. Более совершенный реализовать средствами ВБА не получится в силу сложности
Лучше день потерять — потом за пять минут долететь!