8

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

User Excelllll からの 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

よろしくお願いいたします。

4

3 に答える 3

11

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

使用例:

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
   'lists begin in A1, B1, C1, D1
    For Each c In sht.Range("A1:D1").Cells
        col.Add Application.Transpose(sht.Range(c, sht.cells(Rows.Count, c.column).End(xlup))) 
        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, v, tmp()

    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
        'handle cases where only one value in a column (not passed in as array)
        If Not TypeName(col(i)) Like "*()" Then
            ReDim tmp(1 To 1)
            tmp(1) = col(i)
            col.Remove i
            If i > col.Count Then
                col.Add tmp
            Else
                col.Add tmp, before:=i
            End If
        End If
        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
于 2013-11-05T01:09:44.980 に答える