Listing all possible combination without repetition,VBA

问题

I have a code that work right now and lists numbers at 6 lenght.But they are repetive.But these numbers are repeated.I need unique non-repeated 6 digit. I have this kind of results right now.1 1 1 3 4 6 but i need different and non repeating results.Thank you for helping me.

Sub AllCombinations()
Dim nums(): nums = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
Dim arValues(999999, 5)
Dim n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer, n5 As Integer, n6 As Integer, x As Long

For n1 = 0 To UBound(nums)
    For n2 = 0 To UBound(nums)
        For n3 = 0 To UBound(nums)
            For n4 = 0 To UBound(nums)
                For n5 = 0 To UBound(nums)
                    For n6 = 0 To UBound(nums)
                    arValues(x, 0) = nums(n1)
                    arValues(x, 1) = nums(n2)
                    arValues(x, 2) = nums(n3)
                    arValues(x, 3) = nums(n4)
                    arValues(x, 4) = nums(n5)
                    arValues(x, 5) = nums(n6)
                    x = x + 1
                Next
            Next
        Next
       Next
   Next
  Next
      Range("A1").Resize(1000000, 6).Value2 = arValues

 End Sub

回答1:

As it stands, if you wanted to find combinations of different length or of an array with a different Ubound, you would have to alter your code. This can become very tedious and prone to error. Here is a more general solution that works for arrays of any type, any size, and any length of output.

Sub CombosNoRep(ByRef v() As Variant, r As Long)
Dim i As Long, k As Long, z() As Variant, comboMatrix() As Variant
Dim numRows As Long, numIter As Long, n As Long, count As Long

    count = 1
    n = UBound(v)
    numRows = nChooseK(n, r)

    ReDim z(1 To r)
    ReDim comboMatrix(1 To numRows, 1 To r)
    For i = 1 To r: z(i) = i: Next i

    Do While (count <= numRows)
        numIter = n - z(r) + 1
        For i = 1 To numIter
            For k = 1 To r: comboMatrix(count, k) = v(z(k)): Next k
            count = count + 1
            z(r) = z(r) + 1
        Next i

        For i = r - 1 To 1 Step -1
            If Not (z(i) = (n - r + i)) Then
                z(i) = z(i) + 1
                For k = (i + 1) To r: z(k) = z(k - 1) + 1: Next k
                Exit For
            End If
        Next i
    Loop

    Range("A1").Resize(numRows, r).Value2 = comboMatrix
End Sub

Function nChooseK(n As Long, k As Long) As Long
''returns the number of k-combinations from a set
''of n elements. Mathematically speaking, we have: n!/(k!*(n-k)!)
Dim temp As Double, i As Long
    temp = 1
    For i = 1 To k: temp = temp * (n - k + i) / i: Next i
    nChooseK = CLng(temp)
End Function

Calling it we have:

Sub Test()
Dim myArray(1 To 9) As Variant, i As Long
    For i = 1 To 9: myArray(i) = i: Next i
    Call CombosNoRep(myArray, 6)
End Sub

This quickly outputs all 84 unique combinations.

Let's try it on an array with strings.

Sub Test()
Dim myArray() As Variant, i As Long
    '' Added blank "" as CombosNoRep is expecting base 1 array
    myArray = Array("", "Canada", "England", "Laos", "Ethiopia", "Burma", "Latvia", "Serbia", "Chile", "France", "Tonga")
    Call CombosNoRep(myArray, 4)
End Sub

Here we have all 4-tuples of our array of countries (210 unique combinations).

回答2:

Stagger the nested loops:

Sub AllCombinations()
Dim nums(): nums = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
Dim arValues(999999, 5)
Dim n1 As Integer, n2 As Integer, n3 As Integer, n4 As Integer, n5 As Integer, n6 As Integer, x As Long

For n1 = 0 To UBound(nums)
    For n2 = n1 + 1 To UBound(nums)
        For n3 = n2 + 1 To UBound(nums)
            For n4 = n3 + 1 To UBound(nums)
                For n5 = n4 + 1 To UBound(nums)
                    For n6 = n5 + 1 To UBound(nums)
                    arValues(x, 0) = nums(n1)
                    arValues(x, 1) = nums(n2)
                    arValues(x, 2) = nums(n3)
                    arValues(x, 3) = nums(n4)
                    arValues(x, 4) = nums(n5)
                    arValues(x, 5) = nums(n6)
                    x = x + 1
                Next
            Next
        Next
       Next
   Next
  Next
      Range("A1").Resize(1000000, 6).Value2 = arValues

 End Sub

for all 84 unique combinations.

来源：https://stackoverflow.com/questions/48150054/listing-all-possible-combination-without-repetition-vba

标签

excel

vba

unique

combinations