楼主
liuguansky |
Q:
求助一个算分代码,在此万分感激第一步是：先把不合格的公司删除；再按:如果5个<合格公司<=10个就去掉最高的一个公司，如果10个<合格公司<=20个就去掉最高和最底的一个公司，如果20个<合格公司<=30个就去掉最高和最底的二个公司，如果大于30个公司时去掉最高和最底的3个公司。
第二步是：算这个基准价=（有效平均价+有效最低价）/2；有效平均价是指合格厂家内再去掉的公司剩下的公司总价格再除以剩下的公司总数，有效最低价是指合格厂家内再去掉的公司剩下的最低价格的公司。
第三步是：价格分=100-100*N*abs(基准价-投标价格)/基准价；这里的N是一个系数，当投标价格高于基准价时系数为N=1.5,反之N=0.7，还有里面的ABS是指的绝对值。
第四步就是把合格厂家按价格分降序排列。
A:用如下代码可以实现:
- Sub justtest()
- Dim ar1, ar2, i&, d As New Dictionary, Arr, Arrt(), j As Byte, JZJ As Single, ArrTmp, ArrResult()
- '定义变量
- ar1 = Range(Range("b6"), Range("c6").End(4)).Value
- '获取投标信息,赋值给数组
- ar2 = Range(Range("g6"), Range("g6").End(4)).Value
- '获取合格公司
- For i = 1 To UBound(ar2, 1) '合格公司添加入字典KEY
- d(ar2(i, 1)) = 0
- Next i
- For i = 1 To UBound(ar1, 1) '对投标信息匹配合格公司
- If d.Exists(ar1(i, 1)) Then
- d(ar1(i, 1)) = ar1(i, 2)
- End If
- Next i
- With Range("b5").End(4) '清空待处理区域,并生成表头
- .Offset(1, 0).Resize(Rows.Count - .Row, 4).Clear
- .Offset(3, 0).Resize(1, 4) = Array("投标公司", "投标价格", "", "价格分")
- Arr = SortN(d.Items, d.Keys) '对合格信息进行排序,方便后续处理
- Select Case d.Count '对合格个数进行判断,并相应进行数据取舍
- Case Is < 6 '若<6,则退出程序,不进行后续判断,请把下面的代码修改为exit sub
- '<6未进行相应处理
- ReDim Arrt(1 To d.Count, 1 To 2)
- For i = 1 To d.Count
- For j = 1 To 2
- Arrt(i, j) = Arr(i - 1, j)
- Next j, i
- Case Is < 11
- '去掉最大一个
- ReDim Arrt(1 To d.Count - 1, 1 To 2)
- For i = 1 To d.Count - 1
- For j = 1 To 2
- Arrt(i, j) = Arr(i - 1, j)
- Next j, i
- Case Is < 21
- '去掉最大小各一个
- ReDim Arrt(1 To d.Count - 2, 1 To 2)
- For i = 2 To d.Count - 1
- For j = 1 To 2
- Arrt(i - 1, j) = Arr(i - 1, j)
- Next j, i
- Case Is < 31
- '去掉最大小各两个
- ReDim Arrt(1 To d.Count - 4, 1 To 2)
- For i = 3 To d.Count - 2
- For j = 1 To 2
- Arrt(i - 2, j) = Arr(i - 1, j)
- Next j, i
- Case Else
- '去掉最大小各三个
- ReDim Arrt(1 To d.Count - 6, 1 To 2)
- For i = 4 To d.Count - 3
- For j = 1 To 2
- Arrt(i - 3, j) = Arr(i - 1, j)
- Next j, i
- 100
- End Select
- JZJ = (Arrt(1, 2) + Application.WorksheetFunction.Average(Application.Index(Arrt, 0, 2))) / 2
- '生成基准分
- '价格分=100-100*N*abs(基准价-投标价格)/基准价[N=1.5/0.7]
- '当投标价格高于基准价时系数为N=1.5
- For i = 0 To UBound(Arr, 1) '计算价格分
- If d(Arr(i, 1)) >= JZJ Then
- Arr(i, 2) = VBA.Round(100 - 100 * 1.5 * (d(Arr(i, 1)) - JZJ) / JZJ, 2)
- Else
- Arr(i, 2) = VBA.Round(100 + 100 * 0.7 * (d(Arr(i, 1)) - JZJ) / JZJ, 2)
- End If
- Next i
- ArrTmp = SortN(Application.Transpose(Application.Index(Arr, 0, 2)), _
- Application.Transpose(Application.Index(Arr, 0, 1)), False)
- '排序价格分
- ReDim ArrResult(1 To UBound(ArrTmp, 1), 1 To 4) '定义结果数组
- For i = LBound(ArrTmp, 1) To UBound(ArrTmp, 1) '返回结果数组
- ArrResult(i, 1) = ArrTmp(i, 1)
- ArrResult(i, 2) = d(ArrTmp(i, 1))
- ArrResult(i, 4) = ArrTmp(i, 2)
- Next i
- .Offset(4, 0).Resize(i - 1, 4) = ArrResult '返回结果
- End With
- Set d = Nothing
- End Sub
- Function SortN(ByRef ar1 As Variant, ByRef ar2 As Variant, Optional t As Boolean = True) As Variant
- '数组排序[冒泡排位法]
- Dim i&, j&, k, Arrt()
- ReDim Arrt(LBound(ar1) To UBound(ar1), 1 To 2)
- For i = LBound(ar1) To UBound(ar1) - 1
- For j = i + 1 To UBound(ar1)
- If t Eqv ar1(i) > ar1(j) Then
- k = ar1(i)
- ar1(i) = ar1(j)
- ar1(j) = k
- k = ar2(i)
- ar2(i) = ar2(j)
- ar2(j) = k
- End If
- Next j, i
- For i = LBound(ar1) To UBound(ar1)
- Arrt(i, 1) = ar2(i): Arrt(i, 2) = ar1(i)
- Next i
- SortN = Arrt
- End Function
|