VBA在挑选一个之后find组合并且不放回

我以前的问题在这里： 在find组合后在VBA中过滤 。 现在我想尝试更多的细节。

我现在有一个这样的组合列表：

一个
乙
AB
C
AC
公元前
ABC
d
广告
BD
光盘
Ë
AE
是
CE

我想要一个新的macros是做这个信息，并找出有多lessselect所有字母。 因此，例如选项1将导致：

ABCDE

AC BDE

等等…….

您select一个盒子，并找出所有盒子都需要的可能性。 这是我尝试过的另一个代码，但是由于计算时间太长，所以不能很好地工作：

Public Text, Alpha, Beta, Temp_Result, Temp_Stack, Wgt, Hgt, Stack, Stack_Sum Public Max_Wgt As Double, Max_Hgt As Double, Crt_Wgt, Crt_Hgt, Next_Row As Long, Next_Col As Long Sub ListCombinations() Dim Str_Len As Integer, Len_Text As Integer, TotalComb As Integer Len_Text = Worksheets("Sheet1").Range("A65536").End(xlUp).Row - 1 Worksheets("Sheet2").Range("A2:IJ65536").Clear Next_Row = 1 Next_Col = 1 Stack = 0 Max_Wgt = Worksheets("Limits").Range("B1") Max_Hgt = Worksheets("Limits").Range("B2") ReDim Alpha(1 To Len_Text) For j = 1 To Len_Text Alpha(j) = Worksheets("Sheet1").Cells(j + 1, 1) Next j For i = 1 To Len_Text Str_Len = i ReDim Temp_Result(1 To Str_Len) AddCombination Len_Text, Str_Len Next i Find_Stacks End Sub Private Sub AddCombination(Optional PopSize As Integer = 0, _ Optional SetSize As Integer = 0, _ Optional NextMember As Integer = 0, _ Optional NextItem As Integer = 0) Static iPopSize As Integer Static iSetSize As Integer Static SetMembers() As Integer Dim i As Integer If PopSize <> 0 Then iPopSize = PopSize iSetSize = SetSize ReDim SetMembers(1 To iSetSize) As Integer ReDim Crt_Wgt(1 To iSetSize) As Double ReDim Crt_Hgt(1 To iSetSize) As Double NextMember = 1 NextItem = 1 End If For i = NextItem To iPopSize SetMembers(NextMember) = i Crt_Wgt(NextMember) = Worksheets("Sheet1").Cells(i + 1, 2) Crt_Hgt(NextMember) = Worksheets("Sheet1").Cells(i + 1, 3) If NextMember <> iSetSize Then AddCombination , , NextMember + 1, i + 1 Else If (Application.WorksheetFunction.sum(Crt_Wgt) > Max_Wgt) Or _ (Application.WorksheetFunction.sum(Crt_Hgt) > Max_Hgt) Then Else If Stack = 0 Then SavePermutation SetMembers(), iSetSize Else SaveStack SetMembers(), iSetSize End If End If End If Next i End Sub 'AddCombination Sub SavePermutation(Set_Member, Str_Len As Integer) For i = 1 To Str_Len Temp_Result(i) = Alpha(Set_Member(i)) Next i If Next_Row > 65535 Then Next_Row = 1 Next_Col = Next_Col + 4 End If Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col) = Join(Temp_Result, "") Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col + 1) = Application.WorksheetFunction.sum(Crt_Wgt) Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col + 2) = Application.WorksheetFunction.sum(Crt_Hgt) Action = Find_Number() Next_Row = Next_Row + 1 End Sub Function Find_Number() Text = Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col) Sum_Char = 0 For i = 1 To Len(Text) iChar = Left(Text, 1) Sum_Char = Sum_Char + Worksheets("Sheet1").Cells(WorksheetFunction.Match(iChar, Worksheets("Sheet1").Range("A:A"), 0), 4) Text = Right(Text, Len(Text) - 1) Next i Worksheets("Sheet2").Cells(Next_Row + 1, Next_Col + 3) = Sum_Char End Function Sub Find_Stacks() Dim Len_Text As Integer, Str_Len As Integer Stack_Sum = WorksheetFunction.sum(Worksheets("Sheet1").Range("D:D")) Len_Text = Worksheets("Sheet2").Range("D65536").End(xlUp).Row - 1 Stack = 1 Next_Row = 1 ReDim Alpha(1 To Len_Text) ReDim Beta(1 To Len_Text) For j = 1 To Len_Text Alpha(j) = Worksheets("Sheet2").Cells(j + 1, 1) Beta(j) = Worksheets("Sheet2").Cells(j + 1, 4) Next j Worksheets("Sheet4").Range("A1:B65536").Clear For i = 2 To Len_Text Str_Len = i ReDim Temp_Result(1 To Str_Len) ReDim Temp_Stack(1 To Str_Len) AddCombination Len_Text, Str_Len Next i End Sub Sub SaveStack(Set_Member, Str_Len As Integer) For i = 1 To Str_Len Temp_Result(i) = Alpha(Set_Member(i)) Temp_Stack(i) = Beta(Set_Member(i)) Next i If (Application.WorksheetFunction.sum(Temp_Stack) = Stack_Sum) Then Crt_Text = Join(Temp_Result, "") Len_Char = Len(Crt_Text) For i = 1 To Len_Char Crt_Char = InStr(2, Crt_Text, Left(Crt_Text, 1)) If (Crt_Char > 1) Then GoTo End_Loop End If Crt_Text = Right(Crt_Text, Len(Crt_Text) - 1) Next i Worksheets("Sheet4").Cells(Next_Row + 1, 1) = Join(Temp_Result, ",") Next_Row = Next_Row + 1 End If End_Loop: End Sub 

这个代码我们在高度和重量的表1中的框，表2应该提供所有选项，表3是限制，表4是最终选项。 这个执行时间很长。 我想减less这个，任何人都可以帮助我呢？

如果你需要更多的信息，给我留言！

---

编辑

这是其他的代码，这是上面的代码优先？ 这是我以前的问题的结果。 我只想知道哪个更适合我使用。 为了减less我的执行时间，并转向上面解释的最终结果macros，可以调整所有可能的选项。

 Function stackBox() Dim ws As Worksheet Dim width As Long Dim height As Long Dim numOfBox As Long Dim optionsA() As Variant Dim results() As Variant Dim str As String Dim outputArray As Variant Dim i As Long, j As Long Dim currentSymbol As String '------------------------------------new part---------------------------------------------- Dim maxHeight As Double Dim maxWeight As Double Dim heightarray As Variant Dim weightarray As Variant Dim totalHeight As Double Dim totalWeight As Double '------------------------------------new part---------------------------------------------- Set ws = Worksheets("Sheet1") With ws 'clear last time's output height = .Cells(.Rows.Count, 1).End(xlUp).row If height > 3 Then .Range(.Cells(4, 1), .Cells(height, 1)).ClearContents End If numOfBox = .Cells(1, 1).Value width = .Cells(1, .Columns.Count).End(xlToLeft).Column If width < 2 Then MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..." Exit Function End If '------------------------------------new part---------------------------------------------- maxHeight = .Cells(2, 1).Value maxWeight = .Cells(3, 1).Value ReDim heightarray(1 To 1, 1 To width - 1) ReDim weightarray(1 To 1, 1 To width - 1) heightarray = .Range(.Cells(2, 2), .Cells(2, width)).Value weightarray = .Range(.Cells(3, 2), .Cells(3, width)).Value '------------------------------------new part---------------------------------------------- ReDim optionsA(0 To width - 2) For i = 0 To width - 2 optionsA(i) = .Cells(1, i + 2).Value Next i GenerateCombinations optionsA, results, numOfBox ' copy the result to sheet only once ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1) Count = 0 For i = LBound(results, 1) To UBound(results, 1) If Not IsEmpty(results(i)) Then 'rowNum = rowNum + 1 str = "" totalHeight = 0# totalWeight = 0# For j = LBound(results(i), 1) To UBound(results(i), 1) currentSymbol = results(i)(j) str = str & currentSymbol 'results(i)(j) is the SYMBOL eg A, B, C 'look up box's height and weight , increment the totalHeight/totalWeight updateParam currentSymbol, optionsA, heightarray, weightarray, totalHeight, totalWeight Next j If totalHeight < maxHeight And totalWeight < maxWeight Then Count = Count + 1 outputArray(Count, 1) = str End If '.Cells(rowNum, 1).Value = str End If Next i .Range(.Cells(4, 1), .Cells(UBound(outputArray, 1) + 3, 1)).Value = outputArray End With End Function Sub updateParam(ByRef targetSymbol As String, ByRef symbolArray As Variant, ByRef heightarray As Variant, ByRef weightarray As Variant, ByRef totalHeight As Double, ByRef totalWeight As Double) Dim i As Long Dim index As Long index = -1 For i = LBound(symbolArray, 1) To UBound(symbolArray, 1) If targetSymbol = symbolArray(i) Then index = i Exit For End If Next i If index <> -1 Then totalHeight = totalHeight + heightarray(1, index + 1) totalWeight = totalWeight + weightarray(1, index + 1) End If End Sub Sub GenerateCombinations(ByRef AllFields() As Variant, _ ByRef Result() As Variant, ByVal numOfBox As Long) Dim InxResultCrnt As Integer Dim InxField As Integer Dim InxResult As Integer Dim i As Integer Dim NumFields As Integer Dim Powers() As Integer Dim ResultCrnt() As String NumFields = UBound(AllFields) - LBound(AllFields) + 1 ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination ReDim Powers(0 To NumFields - 1) ' one entry per field name ' Generate powers used for extracting bits from InxResult For InxField = 0 To NumFields - 1 Powers(InxField) = 2 ^ InxField Next For InxResult = 0 To 2 ^ NumFields - 2 ' Size ResultCrnt to the max number of fields per combination ' Build this loop's combination in ResultCrnt ReDim ResultCrnt(0 To NumFields - 1) InxResultCrnt = -1 For InxField = 0 To NumFields - 1 If ((InxResult + 1) And Powers(InxField)) <> 0 Then ' This field required in this combination InxResultCrnt = InxResultCrnt + 1 ResultCrnt(InxResultCrnt) = AllFields(InxField) End If Next If InxResultCrnt = 0 Then Debug.Print "testing" End If 'additional logic here If InxResultCrnt >= numOfBox Then Result(InxResult) = Empty Else ' Discard unused trailing entries ReDim Preserve ResultCrnt(0 To InxResultCrnt) ' Store this loop's combination in return array Result(InxResult) = ResultCrnt End If Next End Sub 

Answer 1

为了解决您减less执行时间的需求，请将这几个简单的原则作为开始

1. 不要在循环内引用表单。 有一些替代品，其中包括
   1. 将范围复制到一个variant array然后在数组上循环
   2. 使用Find ， AutoFilter或SpecialCells来限制所需的引用数量。
2. 不要在循环内ReDim数组，或者至less限制你做的次数。
   1. 如果可能的话在循环之前计算所需的大小，或者
   2. 一旦这个尺寸被使用， Dim到一个大的尺寸，比如100或者1000。 在循环之后重新调整到最终的实际大小。

这两种技术将会产生最大的影响。 别人也可以帮忙包括：

1. Dim 所有variables（使用Option Explicit强制自己做这个）
2. 除非特别需要，否则不要使用Variant数据types。
3. 使用Long而不是Integer

4. 除了重复引用Worksheets集合之外，还可以将variablesdecalre， Set其Set为所需的工作表，然后在其他代码中使用该表。 尤其是当这些表单在循环内被引用时。

    Dim ws as Worksheet Set ws = Worksheets("Sheet2") .... ws.Range(...) ws.Cells(...) etc 

5. 使用Range引用格式.Range(.Cells(r1, c1), .Cells(r2, c2))而不是.Range("StringRange")