Распечатать все перестановки используя рекурсию (2)

Option Explicit
Dim S_Msg As String
 
Private Sub Command1_Click()
  S_Msg = ""
  Pn "1122"
  MsgBox S_Msg
End Sub
 
Public Sub Pn(S As String, Optional SS As String = "")
Dim i As Integer
  If Len(S) = 1 Then
    S_Msg = S_Msg & SS & S & vbLf
  Else
    For i = 1 To Len(S)
      Pn Left$(S, i - 1) & Mid$(S, i + 1), SS & Mid$(S, i, 1)
    Next
  End If
End Sub

Private Sub Command1_Click()
  S_Msg = ""
  Pn "1122"
  DeleteDoubleText S_Msg
  MsgBox S_Msg
End Sub
 
Public Sub Pn(s As String, Optional SS As String = "")
Dim i As Integer
  If Len(s) = 1 Then
    S_Msg = S_Msg & SS & s & vbLf
  Else
    For i = 1 To Len(s)
      Pn Left$(s, i - 1) & Mid$(s, i + 1), SS & Mid$(s, i, 1)
    Next
  End If
End Sub
 
Public Sub DeleteDoubleText(ByRef st As String)
        Dim a, Dict As Object, i As Integer, k As Integer, s() As String
        Set Dict = CreateObject("Scripting.Dictionary")
        a = Split(st, vbLf)
        For i = 0 To UBound(a)
            If Not Dict.Exists(a(i)) Then
                Dict.Add a(i), i
                ReDim Preserve s(k)
                s(k) = a(i)
                k = k + 1
            End If
        Next
        st = Join(s, vbLf)
End Sub

Option Explicit
Dim Dict, S_Msg As String
 
Private Sub Command1_Click()
  Set Dict = CreateObject("Scripting.Dictionary")
  S_Msg = ""
  Pn "1122"
  MsgBox S_Msg
End Sub
 
Public Sub Pn(s As String, Optional SS As String = "")
Dim i As Integer, st As String
  If Len(s) = 1 Then
      st = SS & s
      If Not Dict.Exists(st) Then
          Dict.Add st, st
          S_Msg = S_Msg & st & vbLf
      End If
  Else
    For i = 1 To Len(s)
      Pn Left$(s, i - 1) & Mid$(s, i + 1), SS & Mid$(s, i, 1)
    Next
  End If
End Sub

Function Perms(A As String) As String()
Dim R() As String
Dim Z() As String
    l& = Len(A)
    If l& = 2 Then
       ReDim R(1 To 2) As String
       R(1) = A
       R(2) = Right$(A, 1) & Left$(A, 1)
    Else
       s$ = Left$(A, 1)
       Z = Perms(Mid$(A, 2))
       n& = UBound(Z, 1)
       ReDim R(1 To n& * l&) As String
       p& = 1
       For i& = 1 To n&
           U$ = Z(i&)
           For k& = 1 To l& 
               lu$ = Left$(U$, (k& - 1))
               ru$ = Mid$(U$, k&)
               R(p&) = lu$ & s$ & ru$
               p& = p& + 1
           Next k&
       Next i&
    End If
    Perms = R
End Function
 
Sub Test()
Dim R() As String
    A$ = "1234"
    R = Perms(A$)
    For i& = 1 To UBound(R, 1)
        Debug.Print R(i&)
    Next i&
End Sub