一、场景介绍
某公司为员工提供某项福利补贴，每位员工都有各自的额度（假设为4000元/月），但是员工需要上交等额发票才能报销。并且出于实报实销、规范财务报销的流程的考虑，该公司还做了如下规定：
- 每张发票金额不得大于或等于500元；
- 每位员工上交的发票金额之和必须恰好等于该员工自己的额度，即不能多1分钱，也不能少1分钱。
因此，在公司内经常会出现这样的情况：员工手握一沓小金额发票，用计算器敲敲打打计算了许久，却依然凑不出自己想要的金额。为了让每位员工以最高的效率凑出满意的金额，程序员oddgod开发了此程序，该程序基于Excel VBA语言，可以直接在Excel表格中以点击的方式运行，界面较为友好。
二、程序原理
设向量\(x=(x_1,x_2,...x_N)'\)为\(N\)张发票金额组成的向量，根据排列组合原理，每张发票有“不选取“和“选取”两种状态，则\(N\)张发票共有\(2^N\)种组合方式。定义向量\(y=(y_1,y_2,...y_N)'\)为\(N\)张发票的状态组成的向量，其中：
\[ y_i= \begin{cases} 0, & \text {不选取第$i$张发票} \\ 1, & \text{选取第$i$张发票} \end{cases}\]
因此，每种发票选取方式的总金额为向量的数量积\(x'y=x_1y_1+x_2y_2+...+x_Ny_N\)，可以使用穷举法分别令\(y\)等于下面的值：\(y=(0,0,...,0)'\)、\(y=(0,0,...,1)'\)、...、\(y=(1,1,...,1)'\)。由于每种\(y\)的取值分别对应一个二进制数字（如\(00...0\)、\(00...1\)、\(...\)、\(11...1\)），因此可建立\(y\)的每种取值的映射\(y→Y\)，得到对应的十进制数字\(Y=0,1,2,...,2^N\)，通过对\(Y\)的for循环来得到每种状态组合，然后通过数量积\(x'y\)是否等于目标和\(BingoSum\)来判断该状态组合是否满足要求。
三、程序截图
1. 计算前的准备
用户在C1单元格输入目标和，从E1单元格开始依次向右输入每张票据的金额
2. 开始计算
用户点击“开始计算”按钮后，若找到了满足条件的组合，则会从Excel第3行开始输出每种组合
若未找到满足条件的组合，则会在Excel第3行显示一种向下最接近（稍小于目标和）的组合，并在Excel第4行显示一种向上最接近（稍大于目标和）的组合
3. 对结果排序
用户点击“对结果排序”按钮后，Excel会根据B列的数值由小到大进行排序，将耗费发票张数少的组合排在前面
四、程序代码
1. 开始计算
Sub 开始计算()
'票据金额凑整程序
'作者：oddgod
'版本：1.1
'声明
Dim BingoSum, LargeSum, SmallSum, xy, xsum As Double
Dim BingoCount, imax, iPrint, j, jPrint, k, LengthyBingo, LengthyLarge, LengthySmall, N, yDec, yDecCount As Long
Dim x(), y(), ySmall(), yLarge()
'清除结果区
imax = ActiveSheet.UsedRange.Rows.Count
If imax >= 3 Then
Rows("3:" & imax).Select
Selection.ClearContents
Range("A1").Select
End If
'判断E1单元格是否为空
If Cells(1, 5) = "" Then
Cells(2, 5) = "错误！至少要在E1单元格输入一张票据金额！"
Range("A1").Select
Exit Sub
End If
'定义目标和
BingoSum = Cells(1, 3)
'定义目标数组x的长度N
j = 4
Do
j = j + 1
Loop Until Cells(1, j) = ""
N = j - 5
'定义所有给定票据金额组成的数组x、及其所有元素之和xsum
xsum = 0
ReDim x(1 To N)
For j = 1 To N
x(j) = Cells(1, j + 4)
xsum = xsum + x(j)
Next j
'赋初值
iPrint = 2 '输出用行号，置初值2
BingoCount = 0 '等于目标和的组合计数，置初值0
SmallSum = 0 '比待凑目标和稍小的目标和SmallSum置初值0
LargeSum = xsum '比待凑目标和稍大的目标和LargeSum置初值xsum
'判断目标和BingoSum的一些极端值，并给出处理方法
If BingoSum < 0 Then
Cells(2, 5) = "错误！目标和不能为负！"
Range("A1").Select
Exit Sub
ElseIf BingoSum > xsum Then
Cells(2, 5) = "错误！目标和不能大于所有票据金额总和！"
Range("A1").Select
Exit Sub
ElseIf BingoSum = 0 Then
Cells(2, 5) = "Excel计算完毕，找到了1个满足条件的组合！"
Cells(3, 2) = 0
Cells(3, 3) = 0
Cells(3, 4) = "="
Range("A1").Select
Exit Sub
ElseIf BingoSum = xsum Then
Cells(2, 5) = "Excel计算完毕，找到了1个满足条件的组合！"
Cells(3, 2) = N
Cells(3, 3) = BingoSum
Cells(3, 4) = "="
For j = 5 To N + 4
Cells(3, j) = Cells(1, j)
Next j
Range("A1").Select
Exit Sub
End If
'计算主体程序==================================================================
For yDecCount = 1 To 2 ^ N - 2 'yDecCount为固定的循环次数，不受yDec在计算过程中不断减半的影响
yDec = yDecCount 'yDec为数组y的逆序数组y'所组成的二进制数所对应的十进制数
ReDim y(1 To N) '全部由0、1组成的数组y
Do While yDec > 0
For k = 1 To N '若k=N To 1 Step -1则yDec就不是逆序的了
y(k) = yDec Mod 2
yDec = yDec \ 2
Next k
Loop
'至此生成了一个完整的y
xy = Application.WorksheetFunction.SumProduct(x, y) 'xy为数组x、y的数量积
jPrint = 4 '输出用行号置初值4
LengthyBingo = 0 '满足条件的yBingo的长度置初值0
If xy = BingoSum Then
iPrint = iPrint + 1
BingoCount = BingoCount + 1
For k = 1 To N
If y(k) = 1 Then
jPrint = jPrint + 1
Cells(iPrint, jPrint) = x(k)
LengthyBingo = LengthyBingo + 1
End If
Next k
Cells(iPrint, 2) = LengthyBingo
Cells(iPrint, 3) = BingoSum
Cells(iPrint, 4) = "="
ElseIf BingoCount = 0 And xy < BingoSum And xy > SmallSum Then
SmallSum = xy
ReDim ySmall(1 To N)
For k = 1 To N
ySmall(k) = y(k)
Next k
ElseIf BingoCount = 0 And xy > BingoSum And xy < LargeSum Then
LargeSum = xy
ReDim yLarge(1 To N)
For k = 1 To N
yLarge(k) = y(k)
Next k
End If
If yDecCount Mod 10000 = 0 Then
Cells(2, 5) = "计算进度：" & Int(yDecCount / (2 ^ N - 2) * 100) & "%"
End If
Next yDecCount
'输出结论==================================================================
If BingoCount > 0 Then
Cells(2, 5) = "Excel计算完毕，找到了" & BingoCount & "个满足条件的组合！"
ElseIf BingoCount = 0 And SmallSum > 0 And LargeSum < xsum Then
Cells(2, 5) = "Excel计算完毕，未找到满足条件的组合！下面分别给出一组与目标和向下最接近、一组与目标和向上最接近的和。注意：可能非唯一解！"
jPrint = 4
LengthySmall = 0
For k = 1 To N
If ySmall(k) = 1 Then
jPrint = jPrint + 1
Cells(3, jPrint) = x(k)
LengthySmall = LengthySmall + 1
End If
Next k
Cells(3, 2) = LengthySmall
Cells(3, 3) = SmallSum
Cells(3, 4) = "="
jPrint = 4
LengthyLarge = 0
For k = 1 To N
If yLarge(k) = 1 Then
jPrint = jPrint + 1
Cells(4, jPrint) = x(k)
LengthyLarge = LengthyLarge + 1
End If
Next k
Cells(4, 2) = LengthyLarge
Cells(4, 3) = LargeSum
Cells(4, 4) = "="
ElseIf BingoCount = 0 And SmallSum > 0 And LargeSum = xsum And BingoSum < xsum Then
Cells(2, 5) = "Excel计算完毕，未找到满足条件的组合！下面分别给出一组与目标和向下最接近、一组与目标和向上最接近的和。注意：可能非唯一解！"
jPrint = 4
LengthySmall = 0
For k = 1 To N
If ySmall(k) = 1 Then
jPrint = jPrint + 1
Cells(3, jPrint) = x(k)
LengthySmall = LengthySmall + 1
End If
Next k
Cells(3, 2) = LengthySmall
Cells(3, 3) = SmallSum
Cells(3, 4) = "="
'此时向上最接近组合即为x本身
jPrint = 4
LengthyLarge = N
For k = 1 To N
jPrint = jPrint + 1
Cells(4, jPrint) = x(k)
Next k
Cells(4, 2) = LengthyLarge
Cells(4, 3) = LargeSum
Cells(4, 4) = "="
ElseIf BingoCount = 0 And SmallSum = 0 And LargeSum < xsum And BingoSum > 0 Then
Cells(2, 5) = "Excel计算完毕，未找到满足条件的组合！下面分别给出一组与目标和向下最接近、一组与目标和向上最接近的和。注意：可能非唯一解！"
'此时向下最接近组合即为0
Cells(3, 2) = 0
Cells(3, 3) = 0
Cells(3, 4) = "="
jPrint = 4
LengthyLarge = 0
For k = 1 To N
If yLarge(k) = 1 Then
jPrint = jPrint + 1
Cells(4, jPrint) = x(k)
LengthyLarge = LengthyLarge + 1
End If
Next k
Cells(4, 2) = LengthyLarge
Cells(4, 3) = LargeSum
Cells(4, 4) = "="
Else
Cells(2, 5) = "未知错误，请联系程序作者"
End If
Range("A1").Select
End Sub2. 对结果排序
Sub 对结果排序()
Dim imax, jmax As Long
imax = ActiveSheet.UsedRange.Rows.Count
jmax = ActiveSheet.UsedRange.Columns.Count
Rows("3:" & imax).Select
ActiveWorkbook.Worksheets("票据金额凑整程序").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("票据金额凑整程序").Sort.SortFields.Add Key:=Range("B3:B" & imax), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("票据金额凑整程序").Sort
.SetRange Range(Cells(3, 1), Cells(imax, jmax))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
End Sub