获取无重复元素的字符串数组全排列用于Excel自动筛选条件

问题分析 #

你的原代码存在三个核心问题：

1. 生成排列时未排除已使用的元素，导致出现像10*10*14这类包含重复数字的无效筛选条件
2. 拼接结果时未保留*分隔符，不符合原输入的格式要求
3. 没有去重机制，当输入包含重复数字（如2*2）时会生成大量重复排列

解决方案代码 #

下面的代码会生成所有无重复的有效全排列，并将结果存储在集合中，最后可以直接用于AutoFilter的条件：

Sub GenerateUniquePermutations()
    Dim tbxValue As String
    Dim factors() As String
    Dim usedIndices As Collection
    Dim currentPermutation As String
    Dim uniquePermutations As Collection
    
    ' 获取文本框的值（替换为你的文本框对象）
    tbxValue = "10*12*14" ' ActiveSheet.TextBox4.Value
    
    ' 拆分字符串为数组
    factors = Split(tbxValue, "*")
    
    ' 初始化集合存储唯一排列
    Set uniquePermutations = New Collection
    
    ' 初始化已使用索引集合
    Set usedIndices = New Collection
    
    ' 开始递归生成排列
    Call GeneratePermutations(factors, usedIndices, currentPermutation, uniquePermutations)
    
    ' 输出所有唯一排列（可替换为AutoFilter逻辑）
    Dim perm As Variant
    For Each perm In uniquePermutations
        Debug.Print perm
    Next perm
    
    ' 示例：将排列作为AutoFilter条件使用
    ' ActiveSheet.Range("A:A").AutoFilter Field:=1, Criteria1:=GetFilterArray(uniquePermutations), Operator:=xlFilterValues
End Sub

' 递归生成全排列的核心函数
Sub GeneratePermutations(factors() As String, usedIndices As Collection, currentPerm As String, uniquePerms As Collection)
    Dim i As Integer
    Dim isUsed As Boolean
    Dim newPerm As String
    Dim newUsed As Collection
    
    ' 遍历所有元素
    For i = LBound(factors) To UBound(factors)
        ' 检查当前索引是否已被使用
        isUsed = False
        Dim idx As Variant
        For Each idx In usedIndices
            If idx = i Then
                isUsed = True
                Exit For
            End If
        Next idx
        
        If Not isUsed Then
            ' 创建新的已使用索引集合
            Set newUsed = New Collection
            For Each idx In usedIndices
                newUsed.Add idx
            Next idx
            newUsed.Add i
            
            ' 拼接当前排列字符串
            If currentPerm = "" Then
                newPerm = factors(i)
            Else
                newPerm = currentPerm & "*" & factors(i)
            End If
            
            ' 如果是最后一个元素，添加到唯一集合（自动去重）
            If newUsed.Count = UBound(factors) + 1 Then
                On Error Resume Next ' 重复元素会触发错误，忽略即可
                uniquePerms.Add newPerm, Key:=newPerm
                On Error GoTo 0
            Else
                ' 递归继续生成排列
                Call GeneratePermutations(factors, newUsed, newPerm, uniquePerms)
            End If
        End If
    Next i
End Sub

' 辅助函数：将集合转换为数组，用于AutoFilter的Criteria1参数
Function GetFilterArray(col As Collection) As Variant
    Dim arr() As String
    ReDim arr(1 To col.Count)
    
    Dim i As Integer
    For i = 1 To col.Count
        arr(i) = col(i)
    Next i
    
    GetFilterArray = arr
End Function

代码说明 #

1. 递归生成排列：通过GeneratePermutations函数递归遍历所有未使用的元素，逐步拼接排列字符串
2. 去重机制：利用VBA集合的Key属性，尝试添加重复元素时会触发错误，通过On Error Resume Next忽略重复项，自动保留唯一排列
3. 格式保留：拼接时保留*分隔符，确保生成的条件与原输入格式一致
4. AutoFilter适配：GetFilterArray函数将集合转换为数组，可直接传入AutoFilter的Criteria1参数（配合Operator:=xlFilterValues实现多条件筛选）

测试示例 #

• 输入1*2，会生成：1*2、2*1
• 输入10*12*14，会生成6种唯一排列
• 输入2*2，只会生成2*2（无重复）

内容的提问来源于stack exchange，提问作者Peace