Excel·VBA收益最大的运输路线

看到一个帖子《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, t
    arr = [a1].CurrentRegion: mm = 50000: tt = 1200  '初始总本金、总耗时
    min_t = WorksheetFunction.Min(Application.index(arr, , 5))  '最小耗时
    Set dict = CreateObject("scripting.dictionary"): tm = Timer
    res(1, 1) = "总收益": res(1, 2) = "剩余时间": res(1, 3) = "路线": res(2, 1) = 0
    For 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 Boolean
    dk = dict.Keys: b(1) = dk(0): mrr(1) = mm: trr(1) = tt: x = 1
    Do
        Do 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 Then
                    x = x + 1: b(x) = k2
                    dj = 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 For
                Else
                    If i = UBound(dk) Then Exit Do  '所有终点所需时间都超过剩余耗时，跳出
                End If
            Next
        Loop
        s = ""
        For i = 1 To x  '路线结果
            s = s & "-" & b(i)
        Next
        If trr(x) >= 0 Then
            m = 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) Then
                r = r + 1: res(r, 1) = m: res(r, 2) = trr(x): res(r, 3) = Mid(s, 2)
            End If
        End If
        Do  '线路终点迭代
            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 Then
                    dj = 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 Do
                    Else
                        If 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)
                            Next
                            If m > res(2, 1) Then
                                r = 2: res(r, 1) = m - mm: res(r, 2) = trr(x): res(r, 3) = Mid(s, 2)
                            ElseIf m = res(2, 1) Then
                                r = r + 1: res(r, 1) = m - mm: res(r, 2) = trr(x): res(r, 3) = Mid(s, 2)
                            End If
                        End If
                    End If
                End If
            Next
            change = True  '同次路线最后一个终点迭代完成，下一步迭代之前的起点
        Loop Until change = True
        Do 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 = False
                If k2 <> dk(UBound(dk)) Then  '不是最后1个
                    y = Application.Match(k2, dk, 0): b(x) = dk(y)
                Else
                    b(x) = ""
                End If
            Else
                k1 = 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 Then
                        dj = 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) - dt
                        b(x) = k3: Exit Do  '跳出本次迭代
                    End If
                Next
            End If
        Loop
    Loop Until Len(b(1)) = 0  '所有遍历完后，完成所有进位时b(1)为空值
    [g1].Resize(r, 3) = res
    Debug.Print "路线选择完成，用时" & Format(Timer - tm, "0.00")  '耗时
End Sub
  • 运行结果：最大收益为406115，代码运行耗时14.77秒
    在这里插入图片描述