web-dev-qa-db-ja.com

VBA-4列のデータの可能なすべての組み合わせを書き込みます

3列のデータに対して可能なすべての組み合わせを書き込むためのスクリプトを見つけましたが、4列、場合によっては5列を書き込むようにコードを変更しようとしていますが、その方法がわかりません。誰かが助けることができればそれは素晴らしいことです！変数が続く場所（論理的には行くと思う場所）に変数を追加して、うまくいくと思うことを実行しようとしましたが、説明できない「コンパイルエラー：ループなしで実行」が発生します。

これは、User Excellllからの3つの列（私の変更なし）のコードです。

コードの説明は次のとおりです。「このコードは、列A、B、およびCからデータを取得し、列E、F、およびGで説明した出力を提供します。」

Sub combinations()

Dim c1() As Variant
Dim c2() As Variant
Dim c3() As Variant
Dim out() As Variant
Dim j, k, l, m As Long


Dim col1 As Range
Dim col2 As Range
Dim col3 As Range
Dim out1 As Range


Set col1 = Range("A1", Range("A1").End(xlDown))
Set col2 = Range("B1", Range("B1").End(xlDown))
Set col3 = Range("C1", Range("C1").End(xlDown))

c1 = col1
c2 = col2
c3 = col3

Set out1 = Range("E2", Range("G2").Offset(UBound(c1) * UBound(c2) * UBound(c3)))
out = out1

j = 1
k = 1
l = 1
m = 1


Do While j <= UBound(c1)
    Do While k <= UBound(c2)
        Do While l <= UBound(c3)
            out(m, 1) = c1(j, 1)
            out(m, 2) = c2(k, 1)
            out(m, 3) = c3(l, 1)
            m = m + 1
            l = l + 1
        Loop
        l = 1
        k = k + 1
    Loop
    k = 1
    j = j + 1
Loop


out1.Value = out
End Sub

よろしくお願いします

excelvbacombinations
7
Brendan

5列の場合

Sub combinations()

    Dim c1() As Variant
    Dim c2() As Variant
    Dim c3() As Variant
    Dim c4() As Variant
    Dim c5() As Variant
    Dim out() As Variant
    Dim j As Long, k As Long, l As Long, m As Long, n As Long, o As Long


    Dim col1 As Range
    Dim col2 As Range
    Dim col3 As Range
    Dim col4 As Range
    Dim col5 As Range
    Dim out1 As Range


    Set col1 = Range("A1", Range("A1").End(xlDown))
    Set col2 = Range("B1", Range("B1").End(xlDown))
    Set col3 = Range("C1", Range("C1").End(xlDown))
    Set col4 = Range("D1", Range("D1").End(xlDown))
    Set col5 = Range("E1", Range("E1").End(xlDown))

    c1 = col1
    c2 = col2
    c3 = col3
    c4 = col4
    c5 = col5

    Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4) * UBound(c5)))
    out = out1

    j = 1
    k = 1
    l = 1
    m = 1
    n = 1
    o = 1

    Do While j <= UBound(c1)
        Do While k <= UBound(c2)
            Do While l <= UBound(c3)
                Do While m <= UBound(c4)
                    Do While n <= UBound(c5) ' This now loops correctly
                        out(o, 1) = c1(j, 1)
                        out(o, 2) = c2(k, 1)
                        out(o, 3) = c3(l, 1)
                        out(o, 4) = c4(m, 1)
                        out(o, 5) = c5(n, 1)
                        o = o + 1
                        n = n + 1
                    Loop
                    n = 1
                    m = m + 1
                Loop
                m = 1
                l = l + 1
            Loop
            l = 1
            k = k + 1
        Loop
        k = 1
        j = j + 1
    Loop


    out1.Value = out
End Sub

4列の場合

Sub combinations()

    Dim c1() As Variant
    Dim c2() As Variant
    Dim c3() As Variant
    Dim c4() As Variant

    Dim out() As Variant
    Dim j As Long, k As Long, l As Long, m As Long, n As Long


    Dim col1 As Range
    Dim col2 As Range
    Dim col3 As Range
    Dim col4 As Range

    Dim out1 As Range


    Set col1 = Range("A1", Range("A1").End(xlDown))
    Set col2 = Range("B1", Range("B1").End(xlDown))
    Set col3 = Range("C1", Range("C1").End(xlDown))
    Set col4 = Range("D1", Range("D1").End(xlDown))

    c1 = col1
    c2 = col2
    c3 = col3
    c4 = col4

    Set out1 = Range("G2", Range("K2").Offset(UBound(c1) * UBound(c2) * UBound(c3) * UBound(c4)))
    out = out1

    j = 1
    k = 1
    l = 1
    m = 1
    n = 1


    Do While j <= UBound(c1)
        Do While k <= UBound(c2)
            Do While l <= UBound(c3)
                Do While m <= UBound(c4)
                    out(n, 1) = c1(j, 1)
                    out(n, 2) = c2(k, 1)
                    out(n, 3) = c3(l, 1)
                    out(n, 4) = c4(m, 1)
                    n = n + 1
                    m = m + 1
                Loop
                m = 1
                l = l + 1
            Loop
            l = 1
            k = k + 1
        Loop
        k = 1
        j = j + 1
    Loop


    out1.Value = out
End Sub
3
Santosh

これは、（理由の範囲内で）任意の数の列/値に対して機能する一般的なアプローチです。

Sub ListCombinations()

Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long

    Set sht = ActiveSheet
    For Each c In sht.Range("A1:D1").Cells
        col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
        numCols = numCols + 1
    Next c

    res = Combine(col, "~~")

    For i = 0 To UBound(res)
        arr = Split(res(i), "~~")
        sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
    Next i

End Sub


'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()

    Dim rv() As String
    Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
    Dim t As Long, i As Long, n As Long, ub As Long
    Dim numIn As Long, s As String, r As Long

    numIn = col.Count
    ReDim pos(1 To numIn)
    ReDim lbs(1 To numIn)
    ReDim ubs(1 To numIn)
    ReDim lengths(1 To numIn)
    t = 0
    For i = 1 To numIn  'calculate # of combinations, and cache bounds/lengths
        lbs(i) = LBound(col(i))
        ubs(i) = UBound(col(i))
        lengths(i) = (ubs(i) - lbs(i)) + 1
        pos(i) = lbs(i)
        t = IIf(t = 0, lengths(i), t * lengths(i))
    Next i
    ReDim rv(0 To t - 1) 'resize destination array

    For n = 0 To (t - 1)
        s = ""
        For i = 1 To numIn
            s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
        Next i
        rv(n) = s

        For i = numIn To 1 Step -1
            If pos(i) <> ubs(i) Then   'Not done all of this array yet...
                pos(i) = pos(i) + 1    'Increment array index
                For r = i + 1 To numIn 'Reset all the indexes
                    pos(r) = lbs(r)    '   of the later arrays
                Next r
                Exit For
            End If
        Next i
    Next n

    Combine = rv
End Function
8
Tim Williams

以下のコードを試して、可能なすべての組み合わせを再生成できます（再帰を使用）

Public NextLevel As Integer

Private Sub CommandButton1_Click()
    NextLevel = 1
    Call rrd(1, ActiveSheet.Range("F5"), 1, "")
End Sub

Public Function rrd(initiator As Integer, lim As Integer, NextLeg As Integer,     CreatedComb) As Boolean

    If initiator = lim Then
      ActiveSheet.Range("G" & NextLevel) = CreatedComb & "," & initiator
      NextLevel = NextLevel + 1
    Else
      If NextLeg < lim Then
        ActiveSheet.Range("G" & NextLevel) = CreatedComb & "," & initiator
        NextLevel = NextLevel + 1
        Call rrd(initiator + 1, lim, initiator + 1, CreatedComb & "," & initiator)
      End If
      Call rrd(initiator + 1, lim, initiator, CreatedComb)
    End If

End Function
0
Daniel Dias