我怎樣才能讓這個 vba 按我需要的方式工作？

Question

我修改了這個 vba 代碼以從 10 組對中生成六個組合，其中每個組合只使用一個對數。 但我不能完全得到我想要的，並且有很多重復相同的組合，有些數字甚至沒有組合使用。 我可以得到一些幫助來修復這個代碼嗎？ 謝謝。 這是 vba：

Sub Combs()
    Dim a As Long
    Dim b As Long
    Dim c As Long
    Dim d As Long
    Dim e As Long
    Dim f As Long
    Dim g As Long
    Dim h As Long
    Dim j As Long
    Dim k As Long
    Dim i As Long
    Dim grp
    grp = Range("B1:C10").Value
    Dim arr(1 To 1025, 1 To 10) As Long
    For a = 1 To 2
        For b = 1 To 2
            For c = 1 To 2
                For d = 1 To 2
                    For e = 1 To 2
                        For f = 1 To 2
                            For g = 1 To 2
                                For h = 1 To 2
                                    For j = 1 To 2
                                        For k = 1 To 2
                            i = i + 1
                            arr(i, 1) = grp(1, a)
                            arr(i, 2) = grp(2, b)
                            arr(i, 3) = grp(3, c)
                            arr(i, 4) = grp(4, d)
                            arr(i, 5) = grp(5, e)
                            arr(i, 6) = grp(6, f)
                            arr(i, 7) = grp(7, g)
                            arr(i, 8) = grp(8, h)
                            arr(i, 9) = grp(9, j)
                            arr(i, 10) = grp(10, k)
                                        Next k
                                    Next j
                                Next h
                            Next g
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a
    Application.ScreenUpdating = False
    Range("H2").Resize(1025, 6).Value = arr
    Application.ScreenUpdating = True
End Sub

這是一個示例數據：

Group1  1   2
Group2  3   4
Group3  5   6
Group4  7   8
Group5  9   10
Group6  11  12
Group7  13  14
Group8  15  16
Group9  17  18
Group10 19  20

Answer 1

正如 AcsErno 指出的那樣，問題在於您的程序正在生成十列數字，但 output 僅用於六列。 刪除四列會導致許多重復組合，因為這四列中的唯一部分已被刪除。

解決方案是只生成六列，因此允許它們中的每一個保持唯一。 我已將您的程序重寫為僅生成六列：

Sub Combs()
    Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long
    Dim i As Long, arr(1 To 1025, 1 To 6) As Long
    Dim grp() As Variant
    
    grp = Range("B1:C6").Value
    
    For a = 1 To 2
        For b = 1 To 2
            For c = 1 To 2
                For d = 1 To 2
                    For e = 1 To 2
                        For f = 1 To 2
                            i = i + 1
                            arr(i, 1) = grp(1, a)
                            arr(i, 2) = grp(2, b)
                            arr(i, 3) = grp(3, c)
                            arr(i, 4) = grp(4, d)
                            arr(i, 5) = grp(5, e)
                            arr(i, 6) = grp(6, f)
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a

    Application.ScreenUpdating = False
    Range("H2").Resize(1025, 6).Value = arr
    Application.ScreenUpdating = True
End Sub

注意：數組的上限可以從 1025 減少，因為我們不再使用盡可能多的行。 如果您需要其他組合，您可以在任何一對中添加第三個數字。

一個例子：

如何輸入組合號碼

Sub Combs()
    Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long
    Dim i As Long, arr(1 To 1025, 1 To 6) As Long
    Dim grp() As Variant
    
    grp = Range("B1:E6").Value 'Increasing the width
    
    For a = 1 To 2
        For b = 1 To 2
            For c = 1 To 4 'Changed from 2 to 4
                For d = 1 To 4 'Changed from 2 to 4
                    For e = 1 To 4 'Changed from 2 to 4
                        For f = 1 To 4 'Changed from 2 to 4
                            i = i + 1
                            arr(i, 1) = grp(1, a)
                            arr(i, 2) = grp(2, b)
                            arr(i, 3) = grp(3, c)
                            arr(i, 4) = grp(4, d)
                            arr(i, 5) = grp(5, e)
                            arr(i, 6) = grp(6, f)
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a
    Application.ScreenUpdating = False
    Range("H2").Resize(1025, 6).Value = arr
    Application.ScreenUpdating = True
End Sub

Answer 2

我猜你想從 10 中隨機選擇 select 6

Sub Combos()

    Dim i As Integer, j As Integer, k As Integer, n As Integer
    Dim c As Integer, digit As Integer
    Dim b As String, bb As String
    Dim grp, arr(1 To 1025, 1 To 10) As Long, cols

    ' group data
    grp = Range("B1:C10").Value

    For j = 0 To 31
       b = CStr(WorksheetFunction.Dec2Bin(j, 5))
       For k = 0 To 31
          bb = b & CStr(WorksheetFunction.Dec2Bin(k, 5))
          i = j * 32 + k + 1

          ' select 6 of the 10 columns
          cols = SixFromTen
          Range("V" & i + 1) = Join(cols, ",") ' show combo
          For c = 0 To 5
              n = cols(c) '
              'Debug.Print j, k, n
              digit = CInt(Mid(bb, n, 1))  ' binary digit
              arr(i, c + 1) = grp(n, digit + 1)
          Next
       Next
    Next

    Range("O2").Resize(1025, 6).Value = arr
    MsgBox "Done"

End Sub


Function SixFromTen() As Variant

    Dim num As New Collection, ar(5) As String
    Dim i As Integer, n As Integer
    Dim a As Integer, b As Integer, tmp As Integer

    For n = 1 To 10
        num.Add n
    Next

    For i = 0 To 5
        n = 1 + Int(Rnd() * num.Count)
        ar(i) = num(n)
        num.Remove n
    Next

    'bubble sort
    For a = 0 To 4
        For b = a + 1 To 5
            If CInt(ar(a)) > CInt(ar(b)) Then
                tmp = ar(a)
                ar(a) = ar(b)
                ar(b) = tmp
            End If
        Next
    Next
   
    SixFromTen = ar
    
End Function

或者從 10 中刪除 4，以正確順序留下 6。

Function SixFromTen() As Variant
    Dim num As New Collection, ar(5) As String
    Dim i As Integer, n As Integer

    For n = 1 To 10: num.Add n: Next

    ' remove 4
    For i = 0 To 3
        n = 1 + Int(Rnd() * num.Count)
        num.Remove n
    Next

    For i = 0 To 5: ar(i) = num(i + 1): Next
    SixFromTen = ar   
End Function

Answer 3

閱讀您的評論后，我想我更好地了解您在尋找什么。 聽起來您希望該組合是一組十個數字中六個數字的子集。 這十個數字中的每一個都是兩個值之一。 如果我理解正確，您的問題是您無法從十列中迭代六列。

我將您的四個 For 循環替換為一個遍歷列的循環：

Sub Combs()
    Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, alt As Long
    Dim i As Long, arr(1 To 1025, 1 To 6) As Long
    Dim grp() As Variant
    
    grp = Range("B1:c10").Value
    
    For a = 1 To 2
        For b = 1 To 2
            For c = 1 To 2
                For d = 1 To 2
                    For e = 1 To 2
                        For f = 1 To 2
                            For alt = 0 To 4
                            'Interating the used section through the full 10 columns.
                            'Only six columns are used in each combo, but we change which six are used from those 10
                                i = i + 1
                                arr(i, 1) = grp(1 + alt, a)
                                arr(i, 2) = grp(2 + alt, b)
                                arr(i, 3) = grp(3 + alt, c)
                                arr(i, 4) = grp(4 + alt, d)
                                arr(i, 5) = grp(5 + alt, e)
                                arr(i, 6) = grp(6 + alt, f)
                            Next alt
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a
    Application.ScreenUpdating = False
    Range("H2").Resize(1025, 6).Value = arr
    Application.ScreenUpdating = True
End Sub

注意：這會產生 320 個獨特的組合。 這並不是這些數字對的所有可能組合，要獲得更完整的列表，您可以添加額外的 arrays 並交換列位置。