寻求VBA一维数组添加定值n次的全排列实现简洁逻辑

核心思路是用**集合（Collection）**自动处理去重，每一轮基于上一轮的所有数组生成新组合，直到找到目标数组：

1. 数组转字符串当唯一键：把数组元素用逗号拼接成字符串，作为集合的键——重复数组会因键相同被自动过滤，省去手动去重逻辑。
2. 迭代生成新组合：遍历当前轮的所有数组，对每个数组的每个元素单独加StrokeValue生成新数组，转成字符串后判断是否已存在，不存在则加入下一轮集合。
3. 目标检查：每生成一个新数组就对比目标数组，匹配则立即终止循环。

完整代码示例 #

Sub FindTargetArray()
    Dim StrokeValue As Single
    Dim DistanceMatesArray As Variant
    Dim targetArray As Variant
    Dim currentRound As Collection, nextRound As Collection
    Dim arr As Variant, newArr As Variant
    Dim i As Integer
    Dim arrKey As String, targetKey As String
    
    ' 初始化参数
    StrokeValue = 300
    DistanceMatesArray = Array(300, 300, 300, 300)
    targetArray = Array(300, 600, 600, 300) ' 替换为你的目标数组
    targetKey = Join(targetArray, ",") ' 转字符串用于快速匹配
    
    ' 初始化第一轮集合
    Set currentRound = New Collection
    currentRound.Add DistanceMatesArray, Key:=Join(DistanceMatesArray, ",")
    
    Do
        Set nextRound = New Collection
        
        ' 遍历当前轮所有数组
        For Each arr In currentRound
            ' 对每个元素单独加StrokeValue生成新数组
            For i = LBound(arr) To UBound(arr)
                newArr = arr ' 复制原数组
                newArr(i) = newArr(i) + StrokeValue ' 修改单个元素
                arrKey = Join(newArr, ",")
                
                ' 自动去重：重复键会报错，跳过即可
                On Error Resume Next
                nextRound.Add newArr, Key:=arrKey
                On Error GoTo 0
                
                ' 检查是否命中目标
                If arrKey = targetKey Then
                    Debug.Print "找到目标数组：" & arrKey
                    Exit Sub ' 找到直接退出
                End If
            Next i
        Next arr
        
        ' 更新轮次，继续循环
        Set currentRound = nextRound
    Loop While currentRound.Count > 0
End Sub

代码说明 #

• 自动去重：借助Collection的键唯一性，重复数组添加时会触发错误，用On Error Resume Next跳过，无需额外写去重判断。
• 高效迭代：每一轮只基于上一轮结果生成新组合，避免重复生成同一路径的数组。
• 及时终止：一旦生成目标数组立即退出，不用生成所有可能组合。

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