如何优化数字组合的 vba 代码
Posted
技术标签:
【中文标题】如何优化数字组合的 vba 代码【英文标题】:How can I optimize vba code for combination of numbers 【发布时间】:2020-08-13 21:35:14 【问题描述】:我正在解决一个问题,以找到等于 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
【问题讨论】:
【参考方案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
【讨论】:
以上是关于如何优化数字组合的 vba 代码的主要内容,如果未能解决你的问题,请参考以下文章