如何优化数字组合的 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

我认为这段代码很慢，因为它接触工作表的频率很高。在循环中对工作表进行读取和写入。还有一个递归函数可以循环写入工作表。我不知道您这样做是为了便于使用还是因为您需要显示输出。在需要输出之前避免写入工作表。一次输出所有数据，而不是一次输出一个单元格。请参阅我在Sequence 过程中给出的示例。

我使代码具有完全定义的引用，因此系统必须进行更少的猜测和查找。我怀疑性能变化会很大。

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