|
|
- Sub CalculateBidScores()
- Dim ws As Worksheet
- Set ws = ThisWorkbook.Sheets("Sheet1") ' 请根据实际情况修改工作表名称
-
- Dim lastRow As Long
- lastRow = ws.Cells(ws.Rows.count, "B").End(xlUp).Row ' 假设公司名在B列
-
- Dim A0 As Double
- Dim S As Double
- Dim M As Long
- Dim downRate As Double
- Dim basePrice As Double
- Dim i As Long
-
- ' 假设下浮率已经在某个单元格中定义，例如D1
- downRate = ws.Range("F12").Value
-
- ' 计算A0，这里需要所有合格投标人的评标价
- ' 假设评标价在列C中，从第17行开始
- A0 = Application.WorksheetFunction.Average(ws.Range("C17:C" & lastRow))
-
- ' 根据A0的值确定S
- Select Case A0
- Case Is < 100
- S = 1
- Case Is >= 100 And A0 < 1000
- S = 5
- Case Else
- S = 10
- End Select
-
- ' 计算基准价
- basePrice = CalculateBasePrice(ws.Range("C17:C" & lastRow), S) * (1 - downRate)
-
- ' 循环每一行，计算价格得分
- For i = 17 To lastRow
- Dim bidPrice As Double
- Dim score As Double
- Dim n As Integer
-
- bidPrice = ws.Cells(i, "C").Value ' 假设报价在C列
-
- ' 根据评标价与基准价的比较确定n的值
- If bidPrice > basePrice Then
- n = 3 ' 正向系数
- Else
- n = 1 ' 负向系数
- End If
-
- Debug.Print basePrice
-
- ' 计算价格得分
- score = 40 - 40 * n * Abs(basePrice - bidPrice) / basePrice
- If score < 0 Then score = 0 ' 如果得分小于0，则按0分计
-
- ' 在工作表中填入价格得分
- ws.Cells(i, "F").Value = score ' 假设价格得分在F列
- Next i
- End Sub
- Function CalculateBasePrice(rng As Range, S As Double) As Double
- Dim cell As Range
- Dim price As Double
- Dim roundedPrice As Double
- Dim lowestPrice As Double
- Dim highestPrice As Double
- Dim uniquePrices As Object
- Set uniquePrices = New collection
-
-
- ' 填充Collection对象，保留每个四舍五入后的报价的最低值
- For Each cell In rng
- If Not IsEmpty(cell.Value) Then
- price = Round(cell.Value / S, 0) * S ' 四舍五入到S的倍数
- If Not uniquePrices.Exists(price) Then ' 检查Collection中是否已存在该价格
- uniquePrices.Add price
- Else
- ' 如果已经存在相同四舍五入后的报价，则更新为最低报价
- Dim existingPrice As Variant
- For Each existingPrice In uniquePrices
- If price < existingPrice Then
- ' 移除原有的报价并添加新的更低报价
- uniquePrices.Remove existingPrice
- uniquePrices.Add price
- Exit For
- End If
- Next existingPrice
- End If
- End If
- Next cell
-
- <font color="#ff0000"> ' 将Collection转换为数组
- Dim pricesArray() As Double
- j = 1
- For Each price In uniquePrices
- pricesArray(j) = price
- j = j + 1
- Next price</font>
-
- Dim M As Long
- M = uniquePrices.count
-
- ' 根据M的值去除最高价和最低价
- If M >= 7 Then
- highestPrice = Application.WorksheetFunction.Large(uniquePrices, 1)
- uniquePrices.Remove (highestPrice)
- lowestPrice = Application.WorksheetFunction.Small(uniquePrices, 1)
- uniquePrices.Remove (lowestPrice)
- ElseIf M = 6 Then
- highestPrice = Application.WorksheetFunction.Large(uniquePrices, 1)
- uniquePrices.Remove (highestPrice)
- End If
- ' 计算基准价
- If Not IsEmpty(prices) Then
- CalculateBasePrice = Application.WorksheetFunction.Average(prices)
- Else
- CalculateBasePrice = 0 ' 如果没有报价，则返回0或适当的值
- End If
- End Function
- ' 辅助函数，用于从数组中移除指定数量的异常值（最高或最低）
- Function RemoveOutliers(arr As Variant, ParamArray outliers() As Variant) As Variant
- Dim result() As Variant
- Dim i As Long, j As Long
- Dim outlierCount As Long
- outlierCount = 0
- For Each v In outliers
- outlierCount = outlierCount + 1
- Next v
-
- ReDim result(LBound(arr) To UBound(arr) - outlierCount)
- j = 0
- For i = LBound(arr) To UBound(arr)
- Dim isOutlier As Boolean
- isOutlier = False
- For Each outlier In outliers
- If arr(i) = outlier Then
- isOutlier = True
- Exit For
- End If
- Next outlier
-
- If Not isOutlier Then
- j = j + 1
- result(j) = arr(i)
- End If
- Next i
-
- RemoveOutliers = result
- End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-5-16 11:32
楼主
