How can I optimize vba code for combination of numbers - excel

Question

I am working on a problem to find combinations equal to 100 with different vector length as input. The code is working fine for the small sequence but code takes a lot of time when the sequence of numbers increases. I need to reduce the time as much as I can because sometimes it takes an hour. The maximum value of vector length can be 6 & minimum increment can be 5 so the maximum we can get is 36 numbers and output of their combinations in a set of 6. Any help in the optimization of code to a minimum possible time would be great.
Here is the snap of sheet:
Here is the code:
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

I think this code is slow because of how often it touches the worksheet. There are both read and writes to worksheets in loops. There is also a recursive function that writes to the worksheet in a loop. I can't tell if you are doing this for ease of use or because you need to display the output. Avoid writing to the worksheet until output is required. Output all the data at once, instead of one cell at a time. See the example I give in the Sequence procedure.
I made the code have fully defined references so the system has to do less guessing and lookups. I doubt the performance change will be drastic.
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