查找组合后，在VBA中进行过滤 [英] Filtering in VBA after finding combinations
本文介绍了查找组合后，在VBA中进行过滤的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！
问题描述
我现在可以做出所有可能的组合。但是我的下一步是设置一些参数。这个我的意思是箱子的高度和重量。如果我将A栏中的Sheet2放在箱子名称（A，B，....）中，列B的重量（kg）和色谱柱C的高度（毫米）。然后在Sheet3上放置我的最大高度和最大重量。 B2最大重量为30公斤，C3最大高度为500毫米。
如何让我的宏来检查这些参数，如果他们适合，他们将被放置在列在我以前的问题，如果它超过我的体重或身高，它不会打扰放置它。
希望听到很快:)开始享受excel！
编辑：
框名称重量高度
A 1 0.12
B 5 0.92
C 3 0.5
D 2 0.34
........等
这是我如何放置我的输入信息。我想要这么多的方框，甚至可以达到100个
解决方案
作为前一个解决方案的增强
输入格式
（请在学习我的代码后实现自己的输入/输出farmat）
＃框> <框名称1> <框名称2> ...<框名称N>
< max height> < height 1> < height 2> ...
< max weight> < weight 1> <重量2> ...
<输出结果1>
<输出结果2>
。
。
。
sample Input&输出
3 ABCDE
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
不限于整数，您可以使用浮点数
代码：
函数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
' - ----------------------------- ------新的部分------------------------------------------ ----
Dim maxHeight As Double
Dim maxWeight As Double
Dim heightarray As Variant
Dim weightarray As Variant
Dim totalHeight As Double
Dim totalWeight作为Double
'------------------------------------新的部分----- -----------------------------------------
设置ws = Worksheets（Sheet1）
与ws
'清除上次的输出
height = .Cells（.Rows.Count，1）.End（xlUp）.row
如果高度> 3然后
.Range（.Cells（4，1），.Cells（height，1））。ClearContents
End If
numOfBox = .Cells（1，1） .Value
width = .Cells（1，.Columns.Count）.End（xlToLeft）.Column
如果width< 2然后
MsgBox错误：没有项目，请填充您的项目在单元格B1，C1，...
退出函数
结束如果
'------------------------------------新的部分--------- -------------------------------------
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））值
weightarray = .Range（.Cells（3，2），.Cells（3，宽度））。值
'------------------------------------新的部分 - --------------------------------------------
ReDim optionsA（0到宽度 - 2）
对于i = 0到宽度 - 2
optionsA（i）= .Cells（1，i + 2）.Value
Next i
生成组合选项A，结果，numOfBox
'将结果复制到表格只有一次
ReDim outputArray（1 To UBound（results，1） - LBound（results，1）+ 1，1 To 1）
Count = 0
对于i = LBound（结果，1 ）到UBound（结果，1）
如果不是IsEmpty（结果（i））然后
'rowNum = rowNum + 1
str =
totalHeight = 0＃
totalWeight = 0＃
对于j = LBound（结果（i），1）到UBound（结果（i），1）
currentSymbol = results（i）（j）
str = str& currentSymbol'结果（i）（j）是SYMBOL例如。 A，B，C
'查找框的高度和重量，增加totalHeight / totalWeight
updateParam currentSymbol，optionsA，heightarray，weightarray，totalHeight，totalWeight
Next j
如果totalHeight< maxHeight和totalWeight< maxWeight然后
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使用
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对于i = LBound（symbolArray，1）到UBound（symbolArray，1）
如果targetSymbol = symbolArray（i）然后
index = i
退出
结束如果
下一个我
如果索引<> ; -1然后
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结果（0到2 ^ NumFields - 2）'每个组合一个条目
ReDim Powers（0 To NumFields - 1）'每个字段名称一个条目
'生成从InxResult中提取位的权力
InxField = 0到NumFields - 1
Powers（InxField）= 2 ^ InxField
下一个
对于InxResult = 0到2 ^ NumFields - 2
'Size ResultCrnt为每个组合的最大字段数
'在ResultCrnt中构建此循环的组合
ReDim ResultCrnt（0到NumFields - 1）
InxResultCrnt = -1
对于InxField = 0到NumFields - 1
If（（InxResult + 1）And Powers（InxField））<> 0然后
'此组合中需要此字段
InxResultCrnt = InxResultCrnt + 1
ResultCrnt（InxResultCrnt）= AllFields（InxField）
结束如果
下一个
如果InxResultCrnt = 0然后
Debug.Printtest
End If
'additional logic here
If InxResultCrnt> = numOfBox Then
Result（ InxResult）=空
Else
'放弃未使用的尾随项
ReDim保存ResultCrnt（0到InxResultCrnt）
'存储这个循环的组合返回数组
结果（InxResult）= ResultCrnt
结束如果
下一个
End Sub
After some help on this website I am now looking for more. This was my previous post: stacking and layering boxes in excel
I am now able to make all possible combinations. However my next step would be to set some parameters. By this I mean the height and weight of the boxes. If I were to place on "Sheet2" in Column A by box names (A,B,....) Column B by weight (kg) and Column C by height (millimeters). Then on "Sheet3" I place my maximum height and maximum weight. B2 maximum weight of 30 kg and C3 maximum height of 500 mm.
How can I get my macro to check against these parameters and if they do fit them they are placed in the column as in my previous question and if it goes over my weight or height it does not bother with placing it.
Hope to hear soon :) Starting to enjoy excel!
Edit:
Box name Weight height
A 1 0.12
B 5 0.92
C 3 0.5
D 2 0.34
........etc
This is how I would place my input information. I would like this for many boxes, maybe even up to 100
解决方案
as a enhancement to the previous solution
input format (Please implement your own input/output farmat after studying my code)
<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>
.
.
.
sample Input & output
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
Not limited to integer, you can use floating numbers
Code:
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
这篇关于查找组合后，在VBA中进行过滤的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
查看全文
