Option Explicit
Public resCol As Collection             '存放输出结果
Sub a()
    Dim l As Integer, irow As Long
    Dim tmp As String, t() As String, tt() As String
    Dim i As Integer, k As Integer, kk As Integer
    Set resCol = New Collection         '初始化结果集合
    irow = ActiveSheet.Range("A65536").End(xlUp).Row  '取得数据的数量
    kk = 1
    ''清理，准备输出结果
    ActiveSheet.Range("$B:$B").ClearContents
    For i = 1 To irow
        With ActiveSheet.Cells(i, 1)
        tmp = .Value
        l = Len(tmp)
        ReDim t(1 To l) As String       '初始化数组，将字符取出
        For k = 1 To l
            t(k) = Mid(tmp, k, 1)
        Next
        ReDim tt(1 To l)
        Insert tt, t                    '排列
       
        '输出结果
        For k = i To resCol.Count
            ActiveSheet.Cells(kk, 2).NumberFormatLocal = "@"
            ActiveSheet.Cells(kk, 2).Value = resCol(k)
            kk = kk + 1
        Next
        End With
    Next
    '删除重复值
    ActiveSheet.Range("$B:$B").RemoveDuplicates Columns:=1, Header:=xlNo
End Sub
Sub Insert(ByRef arr() As String, ByRef InsStr() As String)     'arr:排列结果 insstr:尚需进行排列的字符 全排列函数
Dim i As Integer                        '循环变量
Dim j As Integer                        '循环变量
Dim b() As String                       '排列一次后,剩下的字符
Dim temp As String                      '排列结果临时变量

  
j = UBound(InsStr)                      'j: 还有多少个字符需要排列
If j <> 1 Then                          '如果多于一个
    ReDim b(1 To j - 1)                 '初始化剩余字符
    For i = 1 To j - 1                  '除掉Insstr中第一个字符,其余的将进行下次排列
        b(i) = InsStr(i + 1)            '剩余字符保存起来进行下次排列
    Next
    j = UBound(arr)                     '排列结果共包含多少字符
    For i = 1 To j
        If arr(i) = "" Then             '如果排列结果尚未填满
            arr(i) = InsStr(1)          '在空位中填入第一个尚需进行排列的字符
            Insert arr, b               '剩下的字符进行到下一次递归过程!!!!!
            arr(i) = ""                 '清理刚才的填充结果
        End If
    Next
  
Else                                    '如果仅剩余了一个字符需要排列
    For j = 1 To UBound(arr)            '在排列结果中寻找仅剩余的一个空位
        If arr(j) = "" Then             '找到了
            arr(j) = InsStr(1)          '把剩余的一个字符填入
            temp = ""                   '初始化临时变量
            For i = 1 To UBound(arr)
                temp = temp & arr(i)    '整理排列结果
            Next
            resCol.Add temp             '整理的结果保存入排列结果集合
            arr(j) = ""                 '清理刚才的排列
            Exit Sub                    '退出过程
        End If
    Next
End If
End Sub