仅单字符，输入字符串递增时输出结果也递增。

Sub createArr()
    Application.ScreenUpdating = False
    Dim s As String
    s = InputBox("请输入字符串")
    Cells(1, 2) = "开始时间：" & Format(Now(), "hh:mm:ss")
    funArr s
    Cells(2, 2) = "结束时间：" & Format(Now(), "hh:mm:ss")
End Sub

Function funArr(str1 As String, Optional str2 As String = "", Optional m As Long = 1)
    Dim a() As String
    If Len(str1) = 1 Then Exit Function
    For i = 0 To Len(str1) - 1
        ReDim Preserve a(i)
        a(i) = Mid(str1, i + 1, 1)
        str0 = a(i) & Replace(str1, a(i), "")
        If Len(str0) = 2 Then
            Cells(m, 1) = str2 & str0
            m = m + 1
        End If
        funArr Mid(str0, 2) & "", str2 & Left(str0, 1), m
    Next
End Function

新的开始！       2023年7月25日