找到组合后在 VBA 中过滤

Posted 2023-03-10

【中文标题】找到组合后在 VBA 中过滤

【英文标题】：Filtering in VBA after finding combinations

【发布时间】：2012-10-09 02:17:56

【问题描述】：

在这个网站上得到一些帮助后，我现在正在寻找更多。这是我之前的帖子：stacking and layering boxes in excel

我现在可以做出所有可能的组合。但是我的下一步是设置一些参数。我的意思是盒子的高度和重量。如果我要按框名称（A，B，....）将 B 列按重量（kg）和 C 列按高度（毫米）放置在 A 列的“Sheet2”上。然后在“Sheet3”上放置我的最大身高和最大体重。 B2 最大重量为 30 公斤，C3 最大高度为 500 毫米。

我怎样才能让我的宏检查这些参数，如果它们确实适合它们，它们会像我之前的问题一样放在列中，如果它超过我的体重或身高，它不会打扰放置它。

希望很快听到 :) 开始享受 e​​xcel！

---

编辑：

Box name    Weight  height
A              1    0.12
B              5    0.92
C              3    0.5
D              2    0.34

........等等

这就是我放置输入信息的方式。我想要很多盒子，甚至可能多达 100 个

【参考方案1】：

作为对先前解决方案的增强

输入格式 （请在学习我的代码后实现您自己的输入/输出farmat）

<num of box>   <box name 1>  <box name 2> ... <box name N>
<max height>   <height 1>    <height 2>...  
<max weight>   <weight 1>    <weight 2> ...
<output result 1>
<output result 2>
.
.
.

示例输入和输出

3   A   B   C   D   E
7.7 3   1   1   1   2
5.5 2   1   2   3   3
A                   
B                   
AB                  
C                   
AC                  
BC                  
ABC                 
D                   
AD                  
BD                  
CD                  
E                   
AE                  
BE                  
CE

不限于整数，可以使用浮点数

代码：

 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

【讨论】：

为什么我的excel看不到宏运行菜单中的宏？宏正在工作，只是无法选择并将其添加到按钮或其他东西

我还想让这个问题更复杂一点，这是我的新问题：***.com/questions/13151975/…

如果你移动到不同的列，这仍然可以运行在 100 个盒子上吗？

1.如果您想直接调用宏，请将 FUNCTION 更改为 SUB。 2.“向不同的列移动”是什么意思？

如果我尝试使用 100 个盒子，它不起作用。我认为行数一定是有限的，因此我需要向右移动几列才能将它们全部放在一张纸上。