. В общем виде правильно разбивается около 95-98% слов, что является очень неплохим результатом. 
Выложу примерчик может кому пригодится.
Использование:
Text = SplitWord(Text)
Параметры:
Техт - Слово с прилегающими знаками припинания (если есть)
Результат: Слово разделенное знаками переноса
- Код: Выделить всё
Option Explicit
Public Function SplitWord(ByVal Text As String) As String
Dim I As Integer, J As Integer, B As Integer, E As Integer
Dim Bs As String, Es As String
Dim S() As String
'разбиваемое слово должно быть длинее 3 символов
If Len(Text) > 3 Then
'Отделяем знаки припенания скобки, кавычки и тд.
For B = 1 To Len(Text)
If Asc(Mid(Text, B, 1)) > &HBF Then
Exit For
End If
Next B
For E = Len(Text) To 1 Step -1
If Asc(Mid(Text, E, 1)) > &HBF Then
Exit For
End If
Next E
If E > B Then
If B > 0 Then
Bs = Left(Text, B - 1)
End If
If E < Len(Text) Then
Es = Right(Text, Len(Text) - E)
End If
Text = Mid(Text, B, E - B + 1)
End If
'Снова проверяем длину слова
If Len(Text) > 3 Then
'Размечаем гласные буквы
Text = Replace(Text, "А", "А¤")
Text = Replace(Text, "а", "а¤")
Text = Replace(Text, "Е", "Е¤")
Text = Replace(Text, "е", "е¤")
Text = Replace(Text, "И", "И¤")
Text = Replace(Text, "и", "и¤")
Text = Replace(Text, "О", "О¤")
Text = Replace(Text, "о", "о¤")
Text = Replace(Text, "У", "У¤")
Text = Replace(Text, "у", "у¤")
Text = Replace(Text, "Ы", "Ы¤")
Text = Replace(Text, "ы", "ы¤")
Text = Replace(Text, "Э", "Э¤")
Text = Replace(Text, "э", "э¤")
Text = Replace(Text, "Ю", "Ю¤")
Text = Replace(Text, "ю", "ю¤")
Text = Replace(Text, "Я", "Я¤")
Text = Replace(Text, "я", "я¤")
S = Split(Text, "¤")
If UBound(S) > 0 Then
For I = 1 To UBound(S) - 1
'Удвоенные согласные, для легкого чтения рекомендуется разбивать
For J = 1 To Len(S(I)) - 1
If Mid(S(I), J, 1) = Mid(S(I), J + 1, 1) Then
S(I) = Replace(S(I), Mid(S(I), J, 1) & Mid(S(I), J + 1, 1), Mid(S(I), J, 1) & "-" & Mid(S(I), J + 1, 1))
Exit For
End If
Next J
'Распределяем по слогам
If InStr(S(I), "-") = 0 Then
J = Int((Len(S(I)) - 1) / 2)
S(I) = Left(S(I), J) & "-" & Mid(S(I), J + 1)
End If
Next I
'Переразбиваем слово с учетом предыдущих правил
Text = Join(S, "")
S = Split(Text, "-")
'Буквы Й, Ы, Ъ, Ь нельзя отделять от предшествующей буквы
For I = 1 To UBound(S)
If InStr("ЙЫЪЬ", UCase(Left(S(I), 1))) > 0 Then
S(I - 1) = S(I - 1) & Left(S(I), 1)
S(I) = Mid(S(I), 2)
End If
Next I
'Нельзя оставлять на предыдущей строке или переносить на следующую строку одну букву слова
If Len(S(0)) < 2 Then
S(0) = S(0) & S(1)
S(1) = ""
End If
If Len(S(UBound(S))) < 2 Then
S(UBound(S) - 1) = S(UBound(S) - 1) & S(UBound(S))
S(UBound(S)) = ""
ReDim Preserve S(UBound(S) - 1)
End If
'Собираем слово
Text = Join(S, "-")
'Делаем чистку
Text = Replace(Text, "--", "-")
End If
End If
'Возращаем знаки припенания и скобки
Text = Bs & Text & Es
End If
SplitWord = Text
End Function
