How to not scramble punctuation symbols while scrambling words?

[Juggler_IN]

I am unable to retain the position of a punctuation in the text while performing Cambridge Transposition (which scrambles every word in the string except the first and last). The reference code is:

Sub v(strText)
    m = 1: Z = Split(strText, " "): j = UBound(Z)
    For u = 0 To j
        t = Split(StrConv(Z(u), 64), Chr(0)): w = UBound(t) - 1: l = Asc(t(w)): If l < 64 Or (l > 90 And l < 97) Or l > 122 Then e = t(w): w = w - 1 Else e = ""
        If w > 3 Then
            n = t(0): p = w - 1: S = ""
            For i = -p To -1
                S = t(-i) & S
            Next
            f = t(w)
            For p = 1 To p - 1
                r = Int((w - p) * Rnd()) + 1: n = n & Mid(S, r, 1): S = Left(S, r - 1) & Right(S, w - p - r)
            Next
            n = n & S
        Else
            n = Z(u): f = "": e = ""
        End If
        d = d & n & f & e & " "
    Next
    strText = d
End Sub
Sub Test()


    strTestString = "This is a test."
    v strTestString
    Debug.Print strTestString
    
    st = "According to a researcher at Cambridge University, it doesn't matter in what order the letters in a word are, the only important thing is that the first and last letter be at the right place. The rest can be a total mess and you can still read it without problem. This is because the human mind does not read every letter by itself but the word as a whole."
    v st
    Debug.Print strTestString


End Sub

 

[CalcSux78]

I was a bit lost in your logic. I see that you take the phrase and split into individual words. From there, I would load the characters from the second character to the second to last character into a collection (adjusting for the word ending in a punctuation character). Loop back through the same range replacing with a random item from the collection and removing the used items.

Sub Test()
Dim str$: str = "According to a researcher at Cambridge University, it doesn't matter in what order the letters in a word are, the only important thing is that the first and last letter be at the right place. The rest can be a total mess and you can still read it without problem. This is because the human mind does not read every letter by itself but the word as a whole."
Debug.Print Scramble(str)
End Sub


Function Scramble(ByVal Phrase As String) As String
Dim aWords As Variant, i&
aWords = Split(Phrase, " ")
For i = 0 To UBound(aWords)
    aWords(i) = MixWord(aWords(i))
Next
Scramble = Join(aWords, " ")
End Function


Function MixWord(ByVal sWord As String) As String
Dim arr As Variant
Dim i&, n&, iEnd
Dim Letters As New Collection


arr = Split(StrConv(sWord, 64), Chr(0))
Select Case Asc(arr(UBound(arr) - 1))   [COLOR=#008000]'is last character a valid letter[/COLOR]
    Case 65 To 90, 97 To 122
        iEnd = 2
    Case Else
        iEnd = 3
End Select
For i = LBound(arr) + 1 To UBound(arr) - iEnd   [COLOR=#008000]'load characters to scramble in Letters[/COLOR]
    Select Case Asc(arr(i))
        Case 65 To 90, 97 To 122
            Letters.Add arr(i)
    End Select
Next
[COLOR=#008000]'repeat loop but add a random character from Letters back into word[/COLOR]
For i = LBound(arr) + 1 To UBound(arr) - iEnd
    Select Case Asc(arr(i))
        Case 65 To 90, 97 To 122
            n = WorksheetFunction.RandBetween(1, Letters.Count)
            arr(i) = Letters(n)
            Letters.Remove n
    End Select
Next
MixWord = Join(arr, "")
End Function

 

[Rick Rothstein]

Here is another (stand-alone) Scramble function that you can try (call it the same way CalcSux78 showed you for his function)...

Function Scramble(S As Variant) As String
  Dim X As Long, Cnt As Long, RandomIndex As Long
  Dim PatText As String, Text As String
  Dim Temp As Variant, Letters As Variant, Patterns As Variant, Arr As Variant
  PatText = String(Len(S), "@")
  Text = S
  For X = 1 To Len(S)
    If Mid(S, X, 1) Like "[!A-Za-z]" Then
      Mid(PatText, X) = Mid(S, X, 1)
      If Mid(Text, X, 1) <> " " Then Mid(Text, X) = "^"
    End If
  Next
  Text = Replace(Text, "^", "")
  Letters = Split(Text)
  Patterns = Split(PatText)
  Randomize
  For X = 0 To UBound(Letters)
    If Len(Letters(X)) > 2 Then
      Arr = Split(StrConv(Mid(Letters(X), 2, Len(Letters(X)) - 2), vbUnicode), Chr(0))
      For Cnt = UBound(Arr) - 1 To LBound(Arr) Step -1
         RandomIndex = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
         tmp = Arr(RandomIndex)
         Arr(RandomIndex) = Arr(Cnt)
         Arr(Cnt) = tmp
      Next
      Mid(Letters(X), 2) = Join(Arr, "")
      Letters(X) = Format(Letters(X), Patterns(X))
    End If
  Next
  Scramble = Join(Letters)
End Function

 

[DanteAmor]

Here is another (stand-alone) Scramble function that you can try (call it the same way CalcSux78 showed you for his function)...

Testing my function I found a couple of details in your function. If the phrase has a letter and punctuation, it does not show the punctuation or if the phrase ends in a sign, for example:

If the sentence ends in a. Or in exclamation!

I do not know if it happens in the phrases of the OP, let's see what he thinks, while here I leave my proposal.

-----

Function order_the_letters(t As String)
    Dim n As New Collection, c As Variant, cad As String, ncad As String
    Dim ini As String, fin As String, l As Long, i As Long, j As Long, num As Long
    For Each c In Split(t, " ")
        cad = ""
        fin = ""
        ini = Left(c, 1)
        l = Len(c) - 2
        If Len(c) = 2 And Right(c, 1) Like "[!A-Za-z]" Then
            fin = Right(c, 1)
        ElseIf Len(c) > 1 Then
            fin = Right(c, 1)
            l = Len(c) - 2
            If Right(c, 1) Like "[!A-Za-z]" Then fin = Right(c, 2): l = l - 1
        End If
        For i = 1 To l
            n.Add Item:=Mid(Mid(c, 2, l), i, 1)
        Next
        For j = 1 To l
            num = WorksheetFunction.RandBetween(1, n.Count)
            cad = cad & n(num)
            n.Remove num
        Next
        ncad = ncad & ini & cad & fin & " "
    Next
    order_the_letters = Left(ncad, Len(ncad) - 1)
End Function

 

[Rick Rothstein]

...while here I leave my proposal.

Your code will move non-letter characters around within the "word" whereas the OP is trying to avoid that. For example, if the word is "doesn't", your code can move the apostrophe so that something like "dne'sot" can be outputted by your code... the OP wanted to maintain the apostrophe where it originally was, so he would have wanted your code to produce "dneso't" instead.

Testing my function I found a couple of details in your function. If the phrase has a letter and punctuation, it does not show the punctuation or if the phrase ends in a sign, for example:

If the sentence ends in a. Or in exclamation!

Thanks for noticing that! I believe the following modified version of my function corrects the problems...

[table="width: 500"]
[tr]
	[td]Function Scramble(S As Variant) As String
  Dim X As Long, Cnt As Long, RandomIndex As Long
  Dim PatText As String, Text As String
  Dim Temp As Variant, Letters As Variant, Patterns As Variant, Arr As Variant
  PatText = String(Len(S), "@")
  Text = S
  For X = 1 To Len(S)
    If Mid(S, X, 1) Like "[!A-Za-z]" Then
      Mid(PatText, X) = Mid(S, X, 1)
      If Mid(Text, X, 1) <> " " Then Mid(Text, X) = "^"
    End If
  Next
  Text = Replace(Text, "^", "")
  Letters = Split(Text)
  Patterns = Split(PatText)
  For X = 0 To UBound(Letters)
    If Len(Letters(X)) > 2 Then
      Arr = Split(StrConv(Mid(Letters(X), 2, Len(Letters(X)) - 2), vbUnicode), Chr(0))
      For Cnt = UBound(Arr) To LBound(Arr) Step -1
         RandomIndex = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
         tmp = Arr(RandomIndex)
         Arr(RandomIndex) = Arr(Cnt)
         Arr(Cnt) = tmp
      Next
      Mid(Letters(X), 2) = Join(Arr, "")
      Letters(X) = Replace(Format(Letters(X), Replace(Patterns(X), "!", Chr(1))), Chr(1), "!")
    Else
      Letters(X) = Format(Letters(X), Patterns(X))
    End If
  Next
  Scramble = Join(Letters)
End Function[/td]
[/tr]
[/table]

 

[DanteAmor]

Your code will move non-letter characters around within the "word" whereas the OP is trying to avoid that. For example, if the word is "doesn't", your code can move the apostrophe so that something like "dne'sot" can be outputted by your code... the OP wanted to maintain the apostrophe where it originally was, so he would have wanted your code to produce "dneso't" instead.

You're right that was the complicated part.
Here it is fixed.

Function order_the_letters(t As String)
    Dim n As New Collection, c As Variant, cad As String, ncad As String
    Dim ini As String, fin As String, l As Long, i As Long, j As Long, num As Long
    Dim letras(), f As Long, laletra, lapos
    
    For Each c In Split(t, " ")
        cad = ""
        fin = ""
        ini = Left(c, 1)
        l = Len(c) - 2
        If Len(c) = 2 And Right(c, 1) Like "[!A-Za-z]" Then
            fin = Right(c, 1)
        ElseIf Len(c) > 1 Then
            fin = Right(c, 1)
            l = Len(c) - 2
            If Right(c, 1) Like "[!A-Za-z]" Then fin = Right(c, 2): l = l - 1
        End If
        
        For i = 1 To l
            n.Add Item:=Mid(Mid(c, 2, l), i, 1)
        Next
        
        If n.Count > 0 Then
            ReDim letras(1 To n.Count, 1 To 2)
            f = 1
            For j = 1 To l
                If n(j) Like "[!A-Za-z]" Then
                    letras(f, 1) = j
                    letras(f, 2) = n(j)
                    f = f + 1
                End If
            Next
        End If
        
        For j = 1 To l
            num = WorksheetFunction.RandBetween(1, n.Count)
            cad = cad & n(num)
            n.Remove num
        Next
        
        If f > 1 Then
            For i = LBound(letras) To f - 1
                lapos = letras(i, 1)
                laletra = letras(i, 2)
                cad = Replace(cad, laletra, "")
            Next
            For i = LBound(letras) To f - 1
                lapos = Val(letras(i, 1))
                laletra = letras(i, 2)
                cad = WorksheetFunction.Replace(cad, lapos, 1, laletra & Mid(cad, lapos, 1))
            Next
            ncad = ncad & ini & cad & fin & " "
        Else
            ncad = ncad & ini & cad & fin & " "
        End If
    Next
    order_the_letters = Left(ncad, Len(ncad) - 1)
End Function

 

[Juggler_IN]

@Rick;

Your function works

How can we modify it to a non-Cambridge scramble? that is, it does scramble of "all" letters, but retains punctuation?

 

[Rick Rothstein]

@Rick;

Your function works

How can we modify it to a non-Cambridge scramble? that is, it does scramble of "all" letters, but retains punctuation?

I am about to go to sleep, but below is a start... the only problem with it is it does not preserve sentence case (first letter of sentence upper case... the upper case first letter could appear after the first character). I'll try to fix it after I wake up.

[table="width: 500"]
[tr]
	[td]Function Scramble(S As Variant) As String
  Dim X As Long, Cnt As Long, RandomIndex As Long
  Dim PatText As String, Text As String
  Dim Temp As Variant, Letters As Variant, Patterns As Variant, Arr As Variant
  PatText = String(Len(S), "@")
  Text = S
  For X = 1 To Len(S)
    If Mid(S, X, 1) Like "[!A-Za-z]" Then
      Mid(PatText, X) = Mid(S, X, 1)
      If Mid(Text, X, 1) <> " " Then Mid(Text, X) = "^"
    End If
  Next
  Text = Replace(Text, "^", "")
  Letters = Split(Text)
  Patterns = Split(PatText)
  For X = 0 To UBound(Letters)
    If Len(Letters(X)) > 1 Then
      Arr = Split(StrConv(Letters(X), vbUnicode), Chr(0))
      For Cnt = UBound(Arr) To LBound(Arr) Step -1
         RandomIndex = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
         tmp = Arr(RandomIndex)
         Arr(RandomIndex) = Arr(Cnt)
         Arr(Cnt) = tmp
      Next
      Letters(X) = Join(Arr, "")
      Letters(X) = Replace(Format(Letters(X), Replace(Patterns(X), "!", Chr(1))), Chr(1), "!")
    Else
      Letters(X) = Format(Letters(X), Patterns(X))
    End If
  Next
  Scramble = Join(Letters)
End Function[/td]
[/tr]
[/table]

 

[DanteAmor]

@Rick;

Your function works

How can we modify it to a non-Cambridge scramble? that is, it does scramble of "all" letters, but retains punctuation?

I pass you my version:

Function order_the_letters(t As String)
    Dim n As New Collection, c As Variant, cad As String, ncad As String
    Dim ini As String, fin As String, l As Long, i As Long, j As Long, num As Long
    Dim letras(), f As Long, laletra, lapos
    
    For Each c In Split(t, " ")
        cad = ""
        fin = ""
        ini = Left(c, 1)
        If Len(c) > 1 Then fin = Right(c, 1) Else fin = ""
        
        ReDim letras(1 To Len(c), 1 To 2)
        f = 1
        For i = 1 To Len(c)
            n.Add Item:=Mid(c, i, 1)
            If Mid(c, i, 1) Like "[!A-Za-z]" Then
                letras(f, 1) = i
                letras(f, 2) = n(i)
                f = f + 1
            End If
        Next
        
        For j = 1 To Len(c)
            num = WorksheetFunction.RandBetween(1, n.Count)
            cad = cad & n(num)
            n.Remove num
        Next
        
        If f > 1 Then
            For i = LBound(letras) To f - 1
                cad = Replace(cad, letras(i, 2), "")
            Next
            For i = LBound(letras) To f - 1
                lapos = Val(letras(i, 1))
                laletra = letras(i, 2)
                cad = WorksheetFunction.Replace(cad, lapos, 1, laletra & Mid(cad, lapos, 1))
            Next
        End If
        ncad = ncad & cad & " "
    Next
    order_the_letters = Left(ncad, Len(ncad) - 1)
End Function

Let me know if you want to change the first letter to uppercase when there is a capital letter in the word.

 

[Juggler_IN]

@DanteAmor,

The UDF is returning #VALUE ! error.