4-колоночные комбинации W / VBA

Question

У меня есть следующий код:

  Sub combinations()

  Range("G2:G" & Range("G2").End(xlDown).Row).ClearContents
  Range("H2:G" & Range("H2").End(xlDown).Row).ClearContents
  Range("I2:G" & Range("I2").End(xlDown).Row).ClearContents
  Range("J2:G" & Range("J2").End(xlDown).Row).ClearContents

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("A2", Range("A2").End(xlDown))
Set col2 = Range("B2", Range("B2").End(xlDown))
Set col3 = Range("C2", Range("C2").End(xlDown))
Set col4 = Range("D2", Range("D2").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

Создает все возможные комбинации для значений, которые вы вводите от A: A до D: D.

Пример рабочего стола:

           Header1  Header2 Header3 Header4
           A1       B1      C1      D1
           A2       B2      C2      D2
           A3       B3      C3      D3

Единственный раз, когда он не работает, это когда один из столбцов имеет только 1 значение.

Пример неработающего стола:

           Header1  Header2 Header3 Header4
           A1       B1      C1      D1
                    B2      C2      D2
                    B3      C3      D3

Я получаю

Ошибка времени выполнения '1004;

Есть ли способ исправить это, чтобы он работал и для столбцов с 1 значением?

Answer 1

Это должно работать для вас. Обратите внимание, что он будет работать для любого числа столбцов, а не только для 4, и что он также будет работать, если какой-либо из столбцов не заполнен полностью (хотя в каждом столбце должна быть хотя бы одна заполненная ячейка).

Sub tgr()

    Dim ws As Worksheet
    Dim rDest As Range
    Dim aHeaders() As Variant
    Dim aTemp() As Variant
    Dim aData() As Variant
    Dim aResults() As Variant
    Dim vTemp As Variant
    Dim ixData As Long
    Dim ixResult As Long
    Dim ixRow As Long
    Dim ixCol As Long
    Dim lMaxRows As Long
    Dim lResultsBlock As Long
    Dim lOverflowResults As Long
    Dim bPopulated As Boolean

    'Adjust these as necessary
    Set ws = ActiveWorkbook.Worksheets(1)   'The worksheet that contains the table of values
    Set rDest = ws.Range("G2")              'The worksheet and cell where results should be output to
    lResultsBlock = 100000                  'The number of rows the results array can contain before having to output results and then continuing

    'Get table of values that will be used to create combinations, assume table starts in A1 and has headers
    With ws.Range("A1").CurrentRegion
        If .Rows.Count = 1 Then Exit Sub    'No data
        If .Cells.Count = 2 Then
            ReDim aHeaders(1 To 1, 1 To 1)
            aHeaders(1, 1) = .Cells(1).Value
            ReDim aData(1 To 1, 1 To 1)
            aData(1, 1) = .Cells(2).Value
        Else
            aHeaders = .Resize(1).Value
            aData = .Offset(1).Resize(.Rows.Count - 1).Value
        End If
        lMaxRows = UBound(aData, 1) ^ UBound(aData, 2)
        ReDim aResults(1 To lResultsBlock, 1 To UBound(aData, 2))
        lOverflowResults = 0
    End With

    'Clear previous results
    ClearResults rDest

    'Iterate over the table of values and create every possible combination
    For ixRow = 1 To lMaxRows
        'Prevent Excel from looking frozen, show a % percent complete
        If (ixRow - 1) Mod 10000 = 0 Then
            DoEvents
            Application.StatusBar = "Processing: " & Format(ixRow / lMaxRows, "0.00%") & " completed..."
        End If

        'Check if this combination has any empty/blank values
        bPopulated = True
        ReDim aTemp(1 To UBound(aResults, 2))
        For ixCol = 1 To UBound(aResults, 2)
            ixData = Int(((ixRow - 1) Mod (UBound(aData, 1) ^ (UBound(aData, 2) - (ixCol - 1)))) / (UBound(aData, 1) ^ (UBound(aData, 2) - ixCol))) + 1
            vTemp = aData(ixData, ixCol)
            If Len(vTemp) > 0 Then
                aTemp(ixCol) = vTemp
            Else
                'Empty/blank found, skip this combination
                bPopulated = False
                Exit For
            End If
        Next ixCol

        If bPopulated Then
            'No empties/blanks found in this combination, add it to results
            ixResult = ixResult + 1
            For ixCol = 1 To UBound(aResults, 2)
                aResults(ixResult, ixCol) = aTemp(ixCol)
            Next ixCol
            Erase aTemp

            'Output results if the results array is full
            If ixResult = UBound(aResults, 1) Then OutputResults ws, rDest, aResults, ixResult, lOverflowResults, aHeaders
        End If
    Next ixRow

    'Output results if results array is at least partially populated
    If ixResult > 0 Then OutputResults ws, rDest, aResults, ixResult, lOverflowResults, aHeaders
    Application.StatusBar = vbNullString

End Sub

'This will clear any previous results
Sub ClearResults(ByVal arg_rDest As Range)

    Dim ws As Worksheet

    arg_rDest.CurrentRegion.ClearContents
    Application.DisplayAlerts = False
    For Each ws In arg_rDest.Worksheet.Parent.Worksheets
        If ws.Name Like "Overflow Results (*)" Then ws.Delete
    Next ws
    Application.DisplayAlerts = True

End Sub

'This will output the current results array to the appropriate destination, accounting for if a new sheet needs to be created and whether headers need to be provided
Sub OutputResults(ByRef arg_wsDest As Worksheet, _
                  ByVal arg_rDest As Range, _
                  ByRef arg_aResults As Variant, _
                  ByRef arg_ixResult As Long, _
                  ByRef arg_lOverflowResults As Long, _
                  Optional ByVal arg_aHeaders As Variant)

    Dim rDest As Range
    Dim lHeaderRow As Long
    Dim lRowCount As Long
    Dim lColCount As Long

    'Check if this is the first time results are being output
    If arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Row <= arg_rDest.Row Then
        'This is the first time results are being output
        arg_lOverflowResults = 0

        'Check if headers need to be placed
        If IsArray(arg_aHeaders) Then
            If arg_rDest.Row = 1 Then lHeaderRow = 1 Else lHeaderRow = arg_rDest.Row - 1
            With arg_wsDest.Cells(lHeaderRow, arg_rDest.Column).Resize(, UBound(arg_aHeaders, 2))
                .Value = arg_aHeaders
                .Font.Bold = True
            End With
            Set rDest = arg_wsDest.Cells(lHeaderRow + 1, arg_rDest.Column)
        Else
            Set rDest = arg_rDest
        End If
    End If

    'These are used to create a new, empty results array after results are output
    lRowCount = UBound(arg_aResults, 1)
    lColCount = UBound(arg_aResults, 2)

    'Check if there is room left in the current destination worksheet to contain all of the results
    If arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Row + 1 + arg_ixResult > arg_wsDest.Rows.Count Then
        'Not enough room found, create a new sheet to continue outputting results on and apply headers if necessary
        arg_lOverflowResults = arg_lOverflowResults + 1
        Set arg_wsDest = arg_wsDest.Parent.Worksheets.Add(AFter:=arg_wsDest)
        arg_wsDest.Name = "Overflow Results (" & arg_lOverflowResults & ")"
        If IsArray(arg_aHeaders) Then
            With arg_wsDest.Cells(1, arg_rDest.Column).Resize(, UBound(arg_aHeaders, 2))
                .Value = arg_aHeaders
                .Font.Bold = True
            End With
            Set rDest = arg_wsDest.Cells(2, arg_rDest.Column)
        Else
            Set rDest = arg_wsDest.Cells(1, arg_rDest.Column)
        End If
    Else
        'Enough room found, set destination for where results should begin
        If rDest Is Nothing Then Set rDest = arg_wsDest.Cells(arg_wsDest.Rows.Count, arg_rDest.Column).End(xlUp).Offset(1)
    End If

    'Output results
    rDest.Resize(arg_ixResult, UBound(arg_aResults, 2)).Value = arg_aResults

    'Clear the existing results array and create a new, empty results array
    Erase arg_aResults
    ReDim arg_aResults(1 To lRowCount, 1 To lColCount)
    arg_ixResult = 0

End Sub