递归学习之--凑数的通用框架

lsdongjh · 发表于 2020-1-21 16:47

Option Explicit
Dim arrResult As Variant
Sub Test()
Dim arr As Variant, brr As Variant, strMsg As String
ReDim arrResult(0) As String
arr = Array(12, 34, 56, 7, 9, 0.9, 3456, 789, 234.66)
If CheckValHasOK(arr, 830.9, brr) = True Then
arr = ""
If MakeUpNumber(brr, 1, 0, 830.9, arr, True) = True Then
MsgBox "已完成，共有组合：" & UBound(arrResult) & "组"
strMsg = Join(arrResult, vbCrLf)
MsgBox strMsg
Else
MsgBox "没有合适的数字！"
End If
Else
MsgBox "现有数字不满足凑数条件！"
End If
End Sub
'凑数
Function MakeUpNumber(arrList As Variant, lngStartID As Long, dblCur As Double, dblSum As Double, dblResult As Variant, Optional blGetAll As Boolean = True) As Boolean
Dim lngID As Long, lngCurID As Long
Dim dblCur_temp As Double, arrReturn As Variant
Dim blIsOk As Boolean
lngCurID = lngStartID
arrReturn = dblResult
If dblCur = dblSum Then
PushResultToArr arrReturn, arrResult, dblSum
MakeUpNumber = True
Exit Function
ElseIf dblCur < dblSum Then
If IsArray(arrReturn) Then
lngID = UBound(arrReturn) + 1
ReDim Preserve arrReturn(1 To lngID) As Double
Else
lngID = 1
ReDim arrReturn(1 To lngID) As Double
End If
Else
MakeUpNumber = False
Exit Function
End If
If lngCurID > UBound(arrList) Then
MakeUpNumber = False
Exit Function
End If
For lngID = lngStartID To UBound(arrList)
If blIsOk And Not blGetAll Then Exit For
dblCur_temp = dblCur + arrList(lngID)
arrReturn(UBound(arrReturn)) = arrList(lngID)
blIsOk = blIsOk Or MakeUpNumber(arrList, lngID + 1, dblCur_temp, dblSum, arrReturn, blGetAll)
Next
MakeUpNumber = blIsOk
End Function
'是否可以凑数
Function CheckValHasOK(arr As Variant, dblSum As Double, arrResult As Variant) As Boolean
Dim lngID As Long, lngCur As Long
Dim lngStart As Long, lngEnd As Long, dblTemp As Double
QuickSort arr, LBound(arr), UBound(arr), False '原始数组降序
lngStart = -1
lngEnd = UBound(arr)
For lngID = LBound(arr) To UBound(arr)
If arr(lngID) <= dblSum Then
lngStart = lngID
Exit For
End If
Next
If lngStart = -1 Then
CheckValHasOK = False
End If
ReDim arrResult(1 To lngEnd - lngStart + 1) As Double
lngCur = 1: dblTemp = 0
For lngID = lngStart To lngEnd
arrResult(lngCur) = arr(lngID)
dblTemp = dblTemp + arrResult(lngCur)
lngCur = lngCur + 1
Next
If dblTemp < dblSum Then
CheckValHasOK = False
Else
CheckValHasOK = True
End If
End Function
'结果输出
Function PushResultToArr(arrSource As Variant, ByRef arrResult As Variant, dblSum As Double)
Dim strTemp As String
Dim lngID As Long
For lngID = LBound(arrSource) To UBound(arrSource)
strTemp = IIf(strTemp = "", arrSource(lngID), strTemp & "+" & arrSource(lngID))
Next
lngID = UBound(arrResult) + 1
ReDim Preserve arrResult(0 To lngID)
arrResult(lngID) = strTemp & "=" & dblSum
End Function
'快速排序
Function QuickSort(arr As Variant, lngStartID As Long, lngEndID As Long, Optional blIsASC As Boolean = True)
Dim varCheck As Variant
Dim lngS As Long, lngE As Long
If Not IsArray(arr) Then Exit Function
If lngStartID >= lngEndID Then Exit Function
varCheck = arr(lngStartID)
lngS = lngStartID: lngE = lngEndID
While lngS <> lngE
If blIsASC Then
'升序
While lngE > lngS And arr(lngE) >= varCheck
lngE = lngE - 1
Wend
SwapArr arr, lngS, lngE
While lngS < lngE And arr(lngS) <= varCheck
lngS = lngS + 1
Wend
SwapArr arr, lngS, lngE
Else
'降序
While lngE > lngS And arr(lngE) <= varCheck
lngE = lngE - 1
Wend
SwapArr arr, lngS, lngE
While lngS < lngE And arr(lngS) >= varCheck
lngS = lngS + 1
Wend
SwapArr arr, lngS, lngE
End If
Wend
QuickSort arr, lngStartID, lngS - 1, blIsASC
QuickSort arr, lngS + 1, lngEndID, blIsASC
End Function
'数组交换
Private Function SwapArr(arr As Variant, lngA As Long, lngB As Long)
Dim varTemp As Variant
varTemp = arr(lngA)
arr(lngA) = arr(lngB)
arr(lngB) = varTemp
End Function

复制代码

玉阳山人 · 发表于 2020-1-21 16:53

老师威武！抢个沙发先，好好学习学习。

WYS67 · 发表于 2020-1-21 17:01

最好上传个带实例的附件，方便菜鸟们直观地学习。

lsdongjh · 发表于 2020-1-21 17:24

WYS67 发表于 2020-1-21 17:01
最好上传个带实例的附件，方便菜鸟们直观地学习。

Test()就是示例

Sub Test2()
Dim arr As Variant, brr As Variant, strMsg As String
ReDim arrResult(0) As String
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
If CheckValHasOK(arr, 11, brr) = True Then
arr = ""
'blGetAll 为false,只要有一组符合就退出
'输出结果为 1 组
'10+1=11
If MakeUpNumber(brr, 1, 0, 11, arr, False) = True Then
MsgBox "已完成，共有组合：" & UBound(arrResult) & "组"
strMsg = Join(arrResult, vbCrLf)
MsgBox strMsg
Else
MsgBox "没有合适的数字！"
End If
Else
MsgBox "现有数字不满足凑数条件！"
End If
End Sub
Sub Test3()
Dim arr As Variant, brr As Variant, strMsg As String
ReDim arrResult(0) As String
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)
If CheckValHasOK(arr, 11, brr) = True Then
arr = ""
'blGetAll 为True,输出所有结果.blGetAll默认就是true
'输出结果为 11组
'10+1=11
'9+2=11
'8+3=11
'8+2+1=11
'7+4=11
'7+3+1=11
'6+5=11
'6+4+1=11
'6+3+2=11
'5+4+2=11
'5+3+2+1=11
If MakeUpNumber(brr, 1, 0, 11, arr, True) = True Then
MsgBox "已完成，共有组合：" & UBound(arrResult) & "组"
strMsg = Join(arrResult, vbCrLf)
MsgBox strMsg
Else
MsgBox "没有合适的数字！"
End If
Else
MsgBox "现有数字不满足凑数条件！"
End If
End Sub

复制代码

凌空一羽 · 发表于 2020-1-21 17:58

收藏学习，谢谢楼主

aman1516 · 发表于 2020-1-21 20:23

谢谢分享，收藏学习

yzxfelix · 发表于 2022-6-23 08:33

强大啊大师，多发些通用的哈

		自动登录	找回密码
密码			免费注册

[原创] 递归学习之--凑数的通用框架

评分

评分

最新热点 /1