快递费最优方案测算

Public max_price As Double
Dim sj, jg(), m%, n%, k&
Sub main()
    Application.ScreenUpdating = False
    Call initComb '组合初始化
    Dim coll As New Collection
    max_price = 1048576
    With Sheet2
        ar = .Range("g1").CurrentRegion
        row_max = UBound(ar)
        For x = 1 To UBound(ar) / 2
            s = ar(x, 1) & "合" & ar(row_max, 1)
            row_max = row_max - 1
            ar_after = comb2Array(s)
            res_price = compareMinPrice(ar_after)
            fin_min_price = getMaiPrice(res_price, max_price)
            coll.Add (res_price & "-------组合方案: " & s)
        Next
    End With
    Call outResult(coll, fin_min_price)
    Application.ScreenUpdating = False
    MsgBox "最少运费是:" & fin_min_price
End Sub
Private Sub initComb()
    With Sheet1
        r = .Cells(.Rows.Count, 2).End(xlUp).Row
        ar = .Range("a3:j" & r)
        comb_count = UBound(ar)
    End With
    With Sheet2
        .Range("a1:h65535").ClearContents
        For x = 1 To comb_count
            .Cells(x, 1) = x
        Next
    End With
    Call getComCount
End Sub

Sub outResult(coll, minPrice)
    With Sheet1
        .Select
        .Range("m2:m65535").ClearContents
        .[m2] = "最少运费:" & minPrice
        k = 2
        For i = 1 To coll.Count
            ss = coll(i)
            k = k + 1
            .Cells(k, 13) = coll(i)
        Next
    End With
End Sub

Function getMaiPrice(res_price, cur_max_price)
    If res_price < cur_max_price Then
        cur_max_price = res_price
    End If
    getMaiPrice = cur_max_price
End Function

Function compareMinPrice(comb)
    If Not IsEmpty(comb(0)) Then
        ar_comb = comb(0)
        jiage1 = calcYunfei(ar_comb)
    End If
    If Not IsEmpty(comb(1)) Then
        ar_comb = comb(1)
        jiage2 = calcYunfei(ar_comb)
    End If
    sum_jiage = Round(jiage1 + jiage2, 2)
    compareMinPrice = sum_jiage
End Function

Function comb2Array(s)
    ar_split_by_jiahao = Split(s, "合")
    If Len(ar_split_by_jiahao(0)) > 0 Then
        s1 = Split(ar_split_by_jiahao(x), ",")
    End If
    If Len(ar_split_by_jiahao(1)) > 0 Then
        s2 = Split(ar_split_by_jiahao(1), ",")
    End If
    comb2Array = Array(s1, s2)
End Function

Function calcYunfei(ar_comb)
    With Sheet1
        r = .Cells(.Rows.Count, 2).End(xlUp).Row
        ar = .Range("a3:j" & r)
        ar_max_row = UBound(ar)
        ar_cur_comb_max_row = UBound(ar_comb) + 1
        If ar_cur_comb_max_row > 1 And ar_cur_comb_max_row <= ar_max_row Then
            For x = 0 To UBound(ar_comb)
                chongliang = chongliang + ar(ar_comb(x), 4) * 1
                tiji = tiji + ar(ar_comb(x), 3) * 1
            Next
            midu = Round(chongliang / tiji, 2)
            If Len(midu) > 0 Then
                jiage = jiage + chongliang * priceMap(midu)
            End If
        Else
            For x = 0 To UBound(ar_comb)
                midu = ar(ar_comb(x), 5)
                If Len(midu) > 0 Then
                    jiage = jiage + ar(ar_comb(x), 4) * priceMap(midu)
                End If
            Next
        End If
    End With
    calcYunfei = jiage
End Function

Function priceMap(t)
    With Sheet2
        ar = .Range("a1").CurrentRegion
        For x = 2 To UBound(ar)
            '            t = 180
            If t > 1000 Then
                res = 2.4
            ElseIf t >= 801 And t <= 1000 Then
                res = 2.5
            ElseIf t >= 601 And t <= 800 Then
                res = 2.6
            ElseIf t >= 501 And t <= 600 Then
                res = 2.7
            ElseIf t >= 451 And t <= 500 Then
                res = 2.8
            ElseIf t >= 401 And t <= 450 Then
                res = 2.9
            ElseIf t >= 351 And t <= 400 Then
                res = 3
            ElseIf t >= 301 And t <= 350 Then
                res = 3.1
            ElseIf t >= 251 And t <= 300 Then
                res = 3.2
            ElseIf t >= 201 And t <= 250 Then
                res = 3.3
            ElseIf t >= 191 And t <= 200 Then
                res = 3.4
            ElseIf t >= 181 And t <= 190 Then
                res = 3.5
            ElseIf t >= 171 And t <= 180 Then
                res = 3.6
            ElseIf t >= 161 And t <= 170 Then
                res = 3.7
            ElseIf t >= 151 And t <= 160 Then
                res = 3.8
            ElseIf t >= 141 And t <= 150 Then
                res = 3.9
            ElseIf t >= 131 And t <= 140 Then
                res = 4
            ElseIf t >= 121 And t <= 130 Then
                res = 4.1
            ElseIf t >= 111 And t <= 120 Then
                res = 4.2
            ElseIf t >= 100 And t <= 110 Then
                res = 4.3
            ElseIf t <= 100 Then
                res = 500
            End If
        Next
    End With
    priceMap = res
End Function

Private Sub getComCount()
    With Sheet2
        .Select
        m = .[a1].End(4).Row
        tem = 2 ^ m
        If 2 ^ m > .Cells.Rows.Count Then MsgBox "结果行数>" & .Cells.Rows.Count & "溢出 ! 停止宏": Exit Sub
        sj = Application.Transpose([a1].Resize(m))
        ReDim jg(2 ^ m - 1, 2)
        k = 0: tms = Timer
        Call dgBin("", String(m, "0"), 0, 0)
        If [b1] > 0 Then Exit Sub
        .[f:h] = ""
        .[f1].Resize(k, 3) = jg
        .[f1].Resize(k, 3).Sort [h1], 1, , , 2
    End With
End Sub


Sub dgBin(r$, s$, i%, t%)
    Dim j%
    jg(k, 0) = Mid(r, 2)
    jg(k, 1) = "'" & s
    jg(k, 2) = t
    k = k + 1
    For j = i + 1 To m
        Mid(s, j, 1) = "1"
        Call dgBin(r & "," & sj(j), s, j, t + 1)
    Next
    If i > 0 Then Mid(s, i, 1) = "0"
End Sub