Как я могу оптимизировать код VBA для комбинации чисел

Question

Я работаю над проблемой, чтобы найти комбинации, равные 100, с различной длиной вектора в качестве входных данных. Код работает хорошо для небольшой последовательности, но код занимает много времени, когда последовательность чисел увеличивается. Мне нужно максимально сократить время, потому что иногда это занимает час. Максимальное значение длины вектора может быть 6, а минимальное приращение может быть 5, поэтому максимальное число, которое мы можем получить, составляет 36 чисел, и вывод их комбинаций в наборе 6. Любая помощь в оптимизации кода до минимально возможного времени будет большой .

Вот снимок листа:

Вот код:

Sub Combinations()
Dim rRng As Range, p As Integer
Dim vElements, lrow As Long, vresult As Variant

Range("A2:A100").Clear
Call Sequence

lrow = 25

Set rRng = Range("A2", Range("A2").End(xlDown)) ' The set of numbers
p = Range("C2").Value ' How many are picked

vElements = Application.Index(Application.Transpose(rRng), 1, 0)
ReDim vresult(1 To p)
Columns("E").Resize(, p + 5).Clear
Call CombinationsNP(vElements, p, vresult, lrow, 1, 1)
Call Delrow
Call formu
Range("C27:D15000").Clear
End Sub

Sub CombinationsNP(vElements As Variant, p As Integer, vresult As Variant, lrow As Long, iElement As Integer, iIndex As Integer)
Dim i As Integer

For i = iElement To UBound(vElements)
    vresult(iIndex) = vElements(i)
    If iIndex = p Then
        lrow = lrow + 1
        Range("E" & lrow + 1).Resize(, p) = vresult
    Else
        Call CombinationsNP(vElements, p, vresult, lrow, i + 1, iIndex + 1)
    End If
Next i
End Sub

Sub Delrow()
Dim lrow As Long
Dim i As Long
Dim x As Integer

lrow = Cells(Rows.Count, 5).End(xlUp).Row

For i = 27 To lrow + 1
x = Cells(i, 5).Value + Cells(i, 6).Value + Cells(i, 7).Value + Cells(i, 8).Value + Cells(i, 9).Value + Cells(i, 10).Value
If x <> 100 And Cells(i, 5).Value <> "" Then
Cells(i, 5).EntireRow.Delete
i = i - 1
End If
Next i

End Sub

Sub Sequence()
Dim i As Integer
Dim x As Integer
Dim y As Integer
Dim a As Integer
Dim b As Integer

b = Cells(2, 3).Value

For i = 2 To Cells(2, 3).Value - 1
Cells(i, 1).Value = 0
Next i

For y = 0 To 100 Step Cells(8, 3).Value
a = 1

If y <> 0 Then
a = Int(100 / y)
If a > b Then
a = b
End If
End If

For x = 1 To a
Cells(i, 1).Value = y
i = i + 1
Next x

Next y

End Sub

Sub formu()
Dim lastrow As Long

lastrow = Cells(Rows.Count, 5).End(xlUp).Row
Range("D27:D" & lastrow).formula = "=E27&F27&G27&H27&I27&J27"
Range("C27:C" & lastrow).formula = "=IF(COUNTIF($D$27:$D$150000,D27)=1,FALSE,NOT(COUNTIF($D$2:D27,D27)=1))"
Range("$C$26:$C$150000").AutoFilter Field:=1, Criteria1:="TRUE"
Range("C27:C150000").EntireRow.Delete
Sheet5.ShowAllData

End Sub

Answer 1

Я думаю, что этот код медленный из-за того, как часто он касается рабочего листа. Есть как чтение, так и запись на листах в виде циклов. Существует также рекурсивная функция, которая записывает на лист в al oop. Я не могу сказать, если вы делаете это для простоты использования или потому, что вам нужно отобразить вывод. Избегайте записи на лист, пока не потребуется вывод. Выведите все данные сразу, а не по одной ячейке за раз. См. Пример, который я привожу в процедуре Sequence.

Я сделал код полностью определенными ссылками, поэтому система должна меньше гадать и искать. Я сомневаюсь, что изменение производительности будет drasti c.

Option Explicit

Public Sub Combinations()
    Dim rRng As Range
    Dim p As Long

    Dim vElements As Variant
    Dim lrow As Long

    ActiveSheet.Range("A2:A100").Clear
    Sequence

    lrow = 25

    Set rRng = ActiveSheet.Range("A2", ActiveSheet.Range("A2").End(xlDown)) ' The set of numbers
    p = ActiveSheet.Range("C2").Value            ' How many are picked

    vElements = Application.WorksheetFunction.Index(Application.WorksheetFunction.Transpose(rRng), 1, 0)
    ReDim vresult(1 To p)
    ActiveSheet.Columns("E").Resize(, p + 5).Clear
    CombinationsNP vElements, p, vresult, lrow, 1, 1
    Delrow
    formu
    ActiveSheet.Range("C27:D15000").Clear
End Sub

Public Sub CombinationsNP(vElements As Variant, p As Long, vresult As Variant, lrow As Long, ByVal iElement As Long, iIndex As Long)
    Dim i As Long

    For i = iElement To UBound(vElements)
        vresult(iIndex) = vElements(i)
        If iIndex = p Then
            lrow = lrow + 1
            ActiveSheet.Range("E" & lrow + 1).Resize(, p) = vresult
        Else
            CombinationsNP vElements, p, vresult, lrow, i + 1, iIndex + 1
        End If
    Next i
End Sub

Public Sub Delrow()
    Dim lrow As Long
    Dim i As Long
    Dim x As Long

    With ActiveSheet
        lrow = .Cells(.Rows.Count, 5).End(xlUp).Row

        For i = 27 To lrow + 1
            x = .Cells(i, 5).Value + .Cells(i, 6).Value + .Cells(i, 7).Value + .Cells(i, 8).Value + .Cells(i, 9).Value + .Cells(i, 10).Value
            If x <> 100 And .Cells(i, 5).Value <> vbNullString Then
                .Cells(i, 5).EntireRow.Delete
                i = i - 1
            End If
        Next i
    End With
End Sub

Public Sub Sequence()
    Dim i As Long
    Dim x As Long
    Dim y As Long
    Dim a As Long
    Dim b As Long

    ' Example of setting all the cells at once
    With ActiveSheet
        b = .Cells(2, 3).Value
        .Range(.Cells(2, 1), .Cells(b - 1, 1)).Value = 0
    End With

    For y = 0 To 100 Step ActiveSheet.Cells(8, 3).Value
        a = 1

        If y <> 0 Then
            a = Int(100 / y)
            If a > b Then
                a = b
            End If
        End If

        For x = 1 To a
            ActiveSheet.Cells(i, 1).Value = y
            i = i + 1
        Next x
    Next y
End Sub

Public Sub formu()
    Dim lastrow As Long
    With ActiveSheet
        lastrow = .Cells(.Rows.Count, 5).End(xlUp).Row
        .Range("D27:D" & lastrow).Formula = "=E27&F27&G27&H27&I27&J27"
        .Range("C27:C" & lastrow).Formula = "=IF(COUNTIF($D$27:$D$150000,D27)=1,FALSE,NOT(COUNTIF($D$2:D27,D27)=1))"
        .Range("$C$26:$C$150000").AutoFilter Field:=1, Criteria1:="TRUE"
        .Range("C27:C150000").EntireRow.Delete
    End With

    Sheet5.ShowAllData
End Sub