看到一个帖子《excel吧-找出运输收益最大的路线》，根据表中的起点和终点构成的路线，在一定的本金和时间限制下，获取收益最大的运输路线

• 采用类似《Excel·VBA数组排列函数》，尾数循环结束后，对之前的位置进位的方式，获取遍历所有可能路线，最终得到收益最大的运输路线

• 以下代码中内层第1个do循环的作用是，路线一直向前延伸，直到剩余时间不足；内层第2个do循环的作用是，在一条路线延伸到底后，对最后一个起点的其他终点进行计算，判断是否为收益更大的路线；内层第3个do循环的作用是，当一条路线延伸到底后，且路线的最后一个终点是其起点的最后一个终点时，对其起点进行递增为下一个起点，且如果路线上的终点都为其起点的最后一个终点时，一直向前递增

• 以下代码运用了Match函数《Excel·VBA多行多列数据简单汇总》，可查找数值在数组中的位置，返回的index从1开始计数，而在以下代码中查找的都是字典键数组从0开始计数，因此代码中For i = y To UBound(dk)就是从被查找的字符的下一个位置开始循环（VBA字典键顺序为写入字典的顺序）

Sub 运输收益最大路线()'res数组记录输出结果共100行3列（总收益，剩余时间，路线），b记录当前路线，mrr记录每次终点的金额，trr记录剩余时间Dim arr, mm, tt, min_t, dict As Object, res(1 To 100, 1 To 3), r&, i&, j&, x&, y&, s$, m, tarr = [a1].CurrentRegion: mm = 50000: tt = 1200  '初始总本金、总耗时min_t = WorksheetFunction.Min(Application.index(arr, , 5))  '最小耗时Set dict = CreateObject("scripting.dictionary"): tm = Timerres(1, 1) = "总收益": res(1, 2) = "剩余时间": res(1, 3) = "路线": res(2, 1) = 0For i = 2 To UBound(arr)  '字典嵌套字典，记录起止点对应（单位成本，单位收益，耗时）If Not dict.Exists(arr(i, 1)) Then Set dict(arr(i, 1)) = CreateObject("scripting.dictionary")dict(arr(i, 1))(arr(i, 2)) = Array(arr(i, 3), arr(i, 4) - arr(i, 3), arr(i, 5))Next'初始数据，b路线数组，mrr本金数组，trr剩余时间数组Dim b(1 To 20), mrr(1 To 20), trr(1 To 20), dk, k1, k2, k3, dj, ds, dt, change As Booleandk = dict.Keys: b(1) = dk(0): mrr(1) = mm: trr(1) = tt: x = 1DoDo While trr(x) >= min_t  '线路递增k1 = b(x): m = mrr(x): t = trr(x): dk = dict(k1).Keys  '初始状态，m当前本金，t当前剩余时间For i = 0 To UBound(dk)k2 = dk(i): dt = dict(k1)(k2)(2)  '单位耗时If t >= dt Thenx = x + 1: b(x) = k2dj = dict(b(x - 1))(b(x))(0): ds = dict(b(x - 1))(b(x))(1)  '单价、单收益m = m + Int(m / dj) * ds: mrr(x) = m: trr(x) = t - dt  '本金递增、时间递减Exit ForElseIf i = UBound(dk) Then Exit Do  '所有终点所需时间都超过剩余耗时，跳出End IfNextLoops = ""For i = 1 To x  '路线结果s = s & "-" & b(i)NextIf trr(x) >= 0 Thenm = mrr(x) - mm  '总收益If m > res(2, 1) Then  '写入输出数组r = 2: res(r, 1) = m: res(r, 2) = trr(x): res(r, 3) = Mid(s, 2)ElseIf m = res(2, 1) Thenr = r + 1: res(r, 1) = m: res(r, 2) = trr(x): res(r, 3) = Mid(s, 2)End IfEnd IfDo  '线路终点迭代change = False: k1 = b(x - 1): k2 = b(x): t = trr(x - 1)  '原起止点、时间复位dk = dict(k1).Keys: y = Application.Match(k2, dk, 0)  '查找k2出现位置，从1开始计数For i = y To UBound(dk)  '从k2出现位置之后开始循环k3 = dk(i): dt = dict(k1)(k3)(2)If t >= dt Thendj = dict(k1)(k3)(0): ds = dict(k1)(k3)(1)m = mrr(x - 1) + Int(mrr(x - 1) / dj) * ds  '原本金+新收益后的本金If t - dt >= min_t Then  '能够线路递增，修改3个数组，跳出do循环b(x) = k3: mrr(x) = m: trr(x) = t - dt: Exit DoElseIf m >= res(2, 1) Then  '仅终点变化，写入输出数组b(x) = k3: mrr(x) = m: trr(x) = t - dt: s = ""For j = 1 To x   '路线结果s = s & "-" & b(j)NextIf m > res(2, 1) Thenr = 2: res(r, 1) = m - mm: res(r, 2) = trr(x): res(r, 3) = Mid(s, 2)ElseIf m = res(2, 1) Thenr = r + 1: res(r, 1) = m - mm: res(r, 2) = trr(x): res(r, 3) = Mid(s, 2)End IfEnd IfEnd IfEnd IfNextchange = True  '同次路线最后一个终点迭代完成，下一步迭代之前的起点Loop Until change = TrueDo While change = True  '最后一个起点迭代，循环进位b(x) = "": mrr(x) = "": trr(x) = "": x = x - 1  '清除最后1个，进位If x = 1 Then  '第1个起点k2 = b(x): dk = dict.Keys: change = FalseIf k2 <> dk(UBound(dk)) Then  '不是最后1个y = Application.Match(k2, dk, 0): b(x) = dk(y)Elseb(x) = ""End IfElsek1 = b(x - 1): k2 = b(x): dk = dict(k1).Keys: y = Application.Match(k2, dk, 0)For i = y To UBound(dk)  'y从1开始计数，=y即为y的下一个k3 = dk(i): dt = dict(k1)(k3)(2)If trr(x - 1) >= dt Thendj = dict(k1)(k3)(0): ds = dict(k1)(k3)(1): dt = dict(k1)(k3)(2)mrr(x) = mrr(x - 1) + Int(mrr(x - 1) / dj) * ds: trr(x) = trr(x - 1) - dtb(x) = k3: Exit Do  '跳出本次迭代End IfNextEnd IfLoopLoop Until Len(b(1)) = 0  '所有遍历完后，完成所有进位时b(1)为空值[g1].Resize(r, 3) = resDebug.Print "路线选择完成，用时" & Format(Timer - tm, "0.00")  '耗时
End Sub

• 运行结果：最大收益为406115，代码运行耗时14.77秒