VBA中的编码决策树
VBA中的编码决策树
提问于 2017-08-17 10:38:42
我在VBA中创建了如下函数：
Private Enum gridInstruction 'in the class declarations section
Place_Break 'not enumerated to anything specific, so uses default 0,1,2...
Place_Chain
Place_Chain_Flag
Skip
End Enum
Private Function applyRules(ByVal imgGrid As Collection) As gridInstruction 'applies rules to imggrid based on input values
Dim step1 As Boolean
Dim step2 As Byte
Dim step3 As Byte
step1 = (imgGrid("B2").Left = 0)
If firstCol Then
step2 = bestChain("b2", imgGrid)
Select Case step2
Case 1
applyRules = Place_Chain
Case 2
step3 = chainedBy("C2", imgGrid)
Select Case step3
Case 1
applyRules = Skip
Case 2
applyRules = Place_Chain
Case 3
applyRules = Place_Chain
End Select
Case 3
step3 = chainedBy("C3", imgGrid)
Select Case step3
Case 1
applyRules = Skip
Case 2
applyRules = Skip
Case 3
applyRules = Place_Chain
End Select
End Select
Else
step2 = chainedBy("b2", imgGrid)
Select Case step2
Case 1
applyRules = Place_Break
Case 2
step3 = bestChain("A2", imgGrid)
Select Case step3
Case 1
applyRules = Place_Break
Case 2
applyRules = Place_Chain
Case 3
applyRules = Place_Chain_Flag 'set chain flag to come back here when chain next breaks
End Select
Case 3
step3 = bestChain("A3", imgGrid)
Select Case step3
Case 1
applyRules = Skip
Case 2
applyRules = Skip
Case 3
applyRules = Place_Chain
End Select
End Select
End If
End Function其中提及2项额外职能：
Private Function bestChain(imgAddress As String, gridVals As Collection) As Byte和
Private Function chainedBy(imgAddress As String, gridVals As Collection) As Byte返回整数1-3，存储为Byte (几乎可以肯定是过早的优化，但我认为它的可读性并不比Integer或Long)低)
这个函数可以用这样的树结构来概括：
如果不清楚:绿色的椭圆是测试，蓝色箭头是那些测试的结果，橙色框是函数的返回值。没有一个测试是相同的，所以我认为没有任何其他方法来构造决策树(如果我错了，请纠正我)。
但是，当我试图将其放入代码中时，结果会变得很混乱；我担心所有的Select Cases和If语句都很难阅读和维护。
是否有更好的方法来构造这段代码(还有任何值得强调的地方)？注意：这个函数被多次调用，所以我希望尽可能地保持它的流线型，所以任何需要分配更多变量的解决方案都可能对运行时间不利。
附加函数
这里引用的两个附加功能是：
Private Function bestChain(imgAddress As String, gridVals As Collection) As Byte
Dim toparray(1 To 3) As Long
Dim imgX As Long 'column number
Dim imgY As Long 'rownum
Dim imgIndex As Long
Dim nTop As Long, nMid As Long, nBot As Long, testImg As Long 'values of the tops of all images
Dim nTop_img As clsImg
imgX = Range(imgAddress).Column 'use range notation so address can be accessed with worksheet functions
imgY = Range(imgAddress).Row
imgIndex = (imgY - 1) * 3 + imgX '3 * (rownum-1) + column
Set nTop_img = gridVals(imgIndex - 2) ' -1 row +1 col
testImg = gridVals(imgIndex).Top
nMid = gridVals(imgIndex + 1).Top ' +1 col
nBot = gridVals(imgIndex + 4).Top ' +1 row +1 col
If nTop_img Is Nothing Then
toparray(1) = -1 'flag as invalid
Else
toparray(1) = Abs(testImg - nTop_img.Top)
End If
toparray(2) = Abs(testImg - nMid) ' abs distance in y between tops
toparray(3) = Abs(testImg - nBot)
bestChain = posArrMin(toparray)(1) 'index of best match
End Function和
Private Function chainedBy(imgAddress As String, gridVals As Collection) As Byte
Dim toparray(1 To 3) As Long
Dim imgX As Long 'column number
Dim imgY As Long 'rownum
Dim imgIndex As Long
Dim pMid As Long, pBot As Long, testImg As Long 'values of the tops of all images in prev column
Dim pTop_img As clsImg
imgX = Range(imgAddress).Column 'use range notation so address can be accessed with worksheet functions
imgY = Range(imgAddress).Row
imgIndex = (imgY - 1) * 3 + imgX '3 * (rownum-1) + column
Set pTop_img = gridVals(imgIndex - 4) '-1 row - 1 col
testImg = gridVals(imgIndex).Top
pMid = gridVals(imgIndex - 1).Top ' -1 col
pBot = gridVals(imgIndex + 2).Top ' +1 row -1 col
If pTop_img Is Nothing Then
toparray(1) = -1 'flag as invalid
Else
toparray(1) = Abs(testImg - pTop_img.Top)
End If
toparray(2) = Abs(testImg - pMid) ' abs distance in y between tops
toparray(3) = Abs(testImg - pBot)
chainedBy = posArrMin(toparray)(1) 'index of best match
End Function它与BestChain相同，只不过它引用了集合中的一些略有不同的元素。
集合(这两个函数都假定这一点)总是9项大小，它们表示一个3x3网格，其中集合中的每个项都有一个[A1]样式的key。即第3项具有密钥"C1"，第8项为"B3"。每个项目都是clsImage类型的，这是我声明的一个自定义类，但就此代码而言，可以将其视为：
Type clsImg
Top As Long
Left As Long
Width As Long
Height As Long
End Type顶部行(集合项1-3)中的值可以是Nothing。
最后，这两个函数都引用了第三个函数：
Private Function posArrMin(arr() As Long) As Long() 'function to return min value of positive array and its index
'-ve values skipped
'assumes at least 1 non negative value
Dim minVal As Long 'minimum value in array
Dim thisVal As Long 'value to be checked
Dim i As Long 'iterator
Dim minI As Long 'index of smallest value
Dim Results(1 To 2) As Long
minVal = -1
For i = LBound(arr) To UBound(arr)
thisVal = arr(i)
If thisVal >= 0 Then 'otherwise skip
If thisVal < minVal Or minVal = -1 Then 'new min or min needs to be set
minVal = thisVal
minI = i
End If
End If
Next i
Results(1) = minI
Results(2) = minVal
posArrMin = Results 'index, value
End Function它返回一个稍微不寻常的Long(1 To 2)数组--在bestChain和chainedBy函数中只使用第一项，但这是因为这个posArrMin函数在我的代码中的其他地方被重用了
回答 2
Code Review用户
发布于 2018-03-15 23:36:19
我明白你是如何与你的SELECT CASE在ApplyRules上斗争的。这需要一些图表，但我认为这是优化的
Private Function applyRules(ByVal imgGrid As Collection) As gridInstruction
Dim step1 As Boolean
Dim step2 As Byte
Dim step3 As Byte
step1 = (imgGrid("B2").Left = 0)
If firstcol Then
step2 = bestChain("b2", imgGrid)
Else
step2 = chainedBy("b2", imgGrid)
End If
Select Case Str(firstcol & step2)
Case "11"
applyRules = Place_Chain
Case "12", "13"
step3 = chainedBy("C" & step2, imgGrid)
Case "01"
applyRules = Place_Break
Case "02", "03"
step3 = bestChain("A" & step2, imgGrid)
End Select
If Not step2 = 1 Then
Select Case step2 & step3
Case 22, 33
applyRules = Place_Chain
Case 31, 32
applyRules = Skip
Case 21
If firstcol Then Skip
Else: applyRules = Place_Break
End If
Case 23
If firstcol Then
applyRules = Place_Chain
Else: applyRules = Place_Chain_Flag
End If
End Select
End If
End Function显然，如果它们是范围引用，则需要对其中的一些进行限定。
Code Review用户
发布于 2019-10-08 11:15:39
我不是想把它拖上去，但是你考虑过递归函数吗？不久前，我在VBA中创建了一个二进制购物车模型，它使用了一个基本的递归结构，大致如下：-
函数A-调用函数B以将行添加到输出记录集对象-检查叶条件；退出函数(如果是的话)-调用函数C来计算最佳拆分和GINI与当前记录集-过滤当前记录集由L分支条件的最优拆分递归调用函数A，传递过滤记录集-过滤当前记录集按R分支条件-递归调用函数A，传递过滤记录集
这根本不是大量的代码，最困难的部分是习惯于VBA对待ADODB.recordset对象和过滤的方式。
页面原文内容由Code Review提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://codereview.stackexchange.com/questions/173240
复制相关文章
相似问题
腾讯云开发者
