VBA Внутри каждого слова перемешать все буквы, кроме первой и последней

Нужен Word-макрос, который по нажатию на кнопку перемешивает внутри каждого слова все буквы, кроме первой и последней


Ответы (1 шт):

Автор решения: deevroman
Function shuffleStr(kek As String) As String
    If Len(kek) <= 3 Then
        shuffleStr = kek
    Else
        For i = 1 To Len(kek) - 2
            Dim a As Integer
            Dim b As Integer
            a = Int((Len(kek) - 2) * Rnd) + 1
            b = Int((Len(kek) - 2) * Rnd) + 1
            If b < a Then
                Dim tmp As Integer
                tmp = b
                b = a
                a = tmp
            End If
            If a <> b Then
                kek = Left(kek, a) + Mid(kek, b + 1, 1) + Mid(kek, a + 2, b - a - 1) + Mid(kek, a + 1, 1) + Right(kek, Len(kek) - b - 1)
            End If
        Next i
        shuffleStr = kek
    End If
End Function

Private Sub CommandButton_Click()

    Application.ScreenUpdating = False
    Dim wrdFind As Find
    Dim wrdRng As Range
    
    Set wrdRng = Application.ActiveDocument.Content
    Set wrdFind = wrdRng.Find
    
    With wrdFind
        .Text = "<[а-яА-ЯёЁa-zA-Z]*>"
        .MatchWildcards = True
    End With
    
    Dim objUndo As UndoRecord
    Set objUndo = Application.UndoRecord
    objUndo.StartCustomRecord ("Undo Shuffler")

    Do While wrdFind.Execute = True
        wrdRng.Text = shuffleStr(wrdRng.Text)
    Loop
    
    objUndo.EndCustomRecord
    Application.ScreenUpdating = True

End Sub
→ Ссылка