VBA在选择一个而不放回后找到组合 [英] VBA finding combinations after picking one and not placing back

问题描述

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

My previous question was here: Filtering in VBA after finding combinations . I would now like to try a little more detail.

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

I now have a list of combinations like this:

A

B

AB

C

AC

BC < br>
ABC

D

AD

BD

CD

E

AE

BE

CE

A
B
AB
C
AC
BC
ABC
D
AD
BD
CD
E
AE
BE
CE

我想要一个新的宏要做的就是获取这些信息，并找出选择所有字母的选项有多少。因此，例如，选项1将导致：

What I would like a new macro to do is to take this information and find out how many options there are for selecting all letters. So for example Option 1 would result in:

ABCDE

A B C D E

AC BDE

等....

您选择一个框并您会发现拥有所有包装盒所需的可能性。这是我尝试过的另一个代码，但是由于计算时间长而无法很好地工作：

You select one box and you find out the possibilities that are required to have all boxes. This is another code that I have tried, however it does not work very well because long calculation time:

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页是最后的选择。这一个执行时间很长。我想减少这一点，有人可以帮助我吗？

This code we have the boxes on sheet 1 with the height and weight, sheet 2 should provide all options, sheet 3 are the limits and sheet 4 are the final options. This one has a long execution time. I would like to reduce this, can anyone help me with this?

如果您需要更多信息，请给我喊！

If you require more information, give me shout!

编辑

这是另一个代码，相对于上面的代码，它更受欢迎吗？这是我上一个问题的结果。我只想了解哪种方式更适合我。为了减少执行时间并转到上面解释的最终结果宏，请对齐所有可能的选项。

This is the other code, is this prefered over the code above? It was the result from my previous question. I would just like to understand which would be better for me to use. To reduce my execution time and move towards my final result macro explained above, aligning all the options possible.

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 e.g. 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

推荐答案

要解决您减少执行时间的愿望，请以这几个简单的原则作为开始

To address your desire to reduce execution time, apply these few simple princples as a start

1. 不要在循环内引用工作表。有很多选择，包括
   

1. Don't reference the sheet inside loops. There are a number of alternatives, including

1. 将范围复制到变量数组然后在数组上循环


2. 使用查找，自动筛选或 SpecialCells 以限制所需引用的数量。

1. copying a range to a variant array then looping over the array
2. use Find, AutoFilter, or SpecialCells to limit the number of references required.

不要 ReDim 循环内的数组，或者至少限制您执行的次数。

Don't ReDim arrays inside loops, or at least limit the number of times you do.

1. 如果可能的话，请在循环前计算所需的大小，或者


2. Dim 设置为较大的尺寸，例如100或1000，则使用该尺寸的 Redim 。 Redim 循环到最终实际大小后。

1. if possible calculate the required size before the loop, or
2. Dim to a large size, say 100 or 1000, the Redim once that size is used. Redim after the loop to the final actual size.

这两种技术的影响最大。其他无法帮助的还包括：

These two techniques will make the most impact. Others than can also help include:

1. Dim all 您的变量（使用 Option Explicit 强制自己执行此操作）


2. 不要使用 Variant 数据类型，除非有特殊需要。


3. 使用 Long 而不是 Integer



4. 而不是重复引用 Worksheets 集合，而是对变量进行除垢，然后将其 Set 设置为所需的工作表，并在其他代码中使用它。

1. Dim all your variables (use Option Explicit to force yourself to do this)
2. Don't use Variant data type unless there is a specific need to.
3. Use Long rather than Integer

4. Rather than repeatedly referencing the Worksheets collection, decalre a variable, Set it to the required sheet, and use that in the other code. Especially when those sheets are referenced inside a loop.

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

使用 Range 参考格式 .Range（.Cells（r1，c1） ，.Cells（r2，c2））而不是 .Range（ StringRange）

这篇关于VBA在选择一个而不放回后找到组合的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！