Option Explicit
' ============================================================================
' ?? 金额均衡分配系统 - 优化版
' ? 前5%大额案件均分到各组,然后按比例分配,确保双重均衡
' ============================================================================
Sub 精准案件分配_优化版()
Dim startTime As Double: startTime = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error GoTo ErrorHandler
' ========== 初始化工作表 ==========
Dim wsCases As Worksheet, wsMediators As Worksheet, wsGroups As Worksheet
Set wsCases = ThisWorkbook.Sheets("案件列表")
Set wsMediators = ThisWorkbook.Sheets("调解员名单")
Set wsGroups = ThisWorkbook.Sheets("小组设置")
' ========== 读取小组设置 ==========
Dim groupLastRow As Long: groupLastRow = wsGroups.Cells(wsGroups.Rows.Count, 1).End(xlUp).Row
If groupLastRow < 2 Then
MsgBox "【小组设置】无数据!", vbCritical
GoTo CleanUp
End If
Dim groupCount As Long: groupCount = groupLastRow - 1
Dim groups() As Variant
ReDim groups(1 To groupCount, 1 To 9) ' 名称,占比,目标案数,已分案数,目标金额,已分金额,案件列表,金额列表
Dim totalGroupPercent As Double: totalGroupPercent = 0
Dim i As Long, j As Long, k As Long
For i = 1 To groupCount
Dim rowIdx As Long: rowIdx = i + 1
groups(i, 1) = Trim(wsGroups.Cells(rowIdx, 1).Value)
If IsEmpty(wsGroups.Cells(rowIdx, 2)) Or wsGroups.Cells(rowIdx, 2).Value = "" Then
groups(i, 2) = 1# / groupCount
Else
groups(i, 2) = CDbl(wsGroups.Cells(rowIdx, 2).Value) / 100
End If
totalGroupPercent = totalGroupPercent + groups(i, 2)
groups(i, 3) = 0 ' 目标案件数
groups(i, 4) = 0 ' 已分案件
groups(i, 5) = 0 ' 目标金额
groups(i, 6) = 0 ' 已分金额
groups(i, 7) = "" ' 案件列表
groups(i, 8) = "" ' 金额列表
Next i
' 标准化小组比例
If Abs(totalGroupPercent - 1#) > 0.0001 Then
For i = 1 To groupCount
groups(i, 2) = groups(i, 2) / totalGroupPercent
Next i
End If
' ========== 读取调解员信息 ==========
Dim mLastRow As Long: mLastRow = wsMediators.Cells(wsMediators.Rows.Count, 1).End(xlUp).Row
If mLastRow < 2 Then
MsgBox "【调解员名单】无数据!", vbCritical
GoTo CleanUp
End If
Dim mediators() As Variant
ReDim mediators(1 To mLastRow - 1, 1 To 10) ' 索引,姓名,比例,组名,已分案数,已分金额,目标案数,目标金额,案件列表,金额偏差
Dim mCount As Long: mCount = 0
For i = 2 To mLastRow
mCount = mCount + 1
mediators(mCount, 1) = mCount
mediators(mCount, 2) = Trim(wsMediators.Cells(i, 1).Value)
If IsEmpty(wsMediators.Cells(i, 2)) Or wsMediators.Cells(i, 2).Value = "" Then
mediators(mCount, 3) = -1 ' 表示组内均分
Else
mediators(mCount, 3) = CDbl(wsMediators.Cells(i, 2).Value) / 100
End If
mediators(mCount, 4) = Trim(wsMediators.Cells(i, 3).Value)
mediators(mCount, 5) = 0 ' 已分案数
mediators(mCount, 6) = 0 ' 已分金额
mediators(mCount, 7) = 0 ' 目标案数
mediators(mCount, 8) = 0 ' 目标金额
mediators(mCount, 9) = "" ' 案件列表
mediators(mCount, 10) = 0 ' 金额偏差
Next i
' ========== 读取未分配案件 ==========
Dim cLastRow As Long: cLastRow = wsCases.Cells(wsCases.Rows.Count, 1).End(xlUp).Row
Dim caseList() As Variant
ReDim caseList(1 To cLastRow - 1, 1 To 3) ' 行号,案号,金额
Dim caseCount As Long: caseCount = 0
Dim totalAmount As Double: totalAmount = 0
For i = 2 To cLastRow
If Not IsEmpty(wsCases.Cells(i, 3)) And Trim(wsCases.Cells(i, 3).Value) <> "" Then GoTo SkipCase
caseCount = caseCount + 1
caseList(caseCount, 1) = i
caseList(caseCount, 2) = CStr(wsCases.Cells(i, 1).Value)
caseList(caseCount, 3) = CDbl(wsCases.Cells(i, 2).Value)
totalAmount = totalAmount + caseList(caseCount, 3)
SkipCase:
Next i
If caseCount = 0 Then
MsgBox "没有需要分配的案件!请确保第3列为空。", vbInformation
GoTo CleanUp
End If
' ========== 按金额降序排序 ==========
Call QuickSortByAmount(caseList, 1, caseCount)
' ========== 核心算法:优化版双重均衡分配 ==========
' 第一步:计算小组目标
Dim remainingCases As Long: remainingCases = caseCount
For i = 1 To groupCount
' 案件数目标(四舍五入)
groups(i, 3) = Round(caseCount * groups(i, 2))
remainingCases = remainingCases - groups(i, 3)
Next i
' 调整案件数,确保总数正确
If remainingCases <> 0 Then
' 计算小数余数
Dim groupRemainders() As Variant
ReDim groupRemainders(1 To groupCount)
For i = 1 To groupCount
Dim decimalPart As Double
decimalPart = (caseCount * groups(i, 2)) - Int(caseCount * groups(i, 2))
groupRemainders(i) = Array(i, decimalPart, groups(i, 1))
Next i
' 按小数部分排序
Call SortByDecimalDesc(groupRemainders, 1, groupCount)
If remainingCases > 0 Then
' 给小数部分大的组增加案件
For i = 1 To remainingCases
If i > groupCount Then Exit For
Dim incIdx As Long
incIdx = groupRemainders(i)(0)
groups(incIdx, 3) = groups(incIdx, 3) + 1
Next i
Else
' 减少案件
For i = 1 To Abs(remainingCases)
If i > groupCount Then Exit For
Dim decIdx As Long
decIdx = groupRemainders(groupCount - i + 1)(0)
If groups(decIdx, 3) > 0 Then
groups(decIdx, 3) = groups(decIdx, 3) - 1
End If
Next i
End If
End If
' 第二步:识别前5%大额案件
Dim top5PercentCount As Long: top5PercentCount = Round(caseCount * 0.05)
If top5PercentCount < 1 Then top5PercentCount = 1
' 大额案件均分到各组
Dim bigCaseCountPerGroup As Long: bigCaseCountPerGroup = top5PercentCount \ groupCount
Dim bigCaseRemainder As Long: bigCaseRemainder = top5PercentCount Mod groupCount
' 初始化组的大额案件计数
Dim groupBigCaseCount() As Long
ReDim groupBigCaseCount(1 To groupCount)
For i = 1 To groupCount
groupBigCaseCount(i) = bigCaseCountPerGroup
If i <= bigCaseRemainder Then
groupBigCaseCount(i) = groupBigCaseCount(i) + 1
End If
Next i
' 第三步:分配大额案件到小组(轮询分配)
Dim bigCaseIndex As Long: bigCaseIndex = 0
Dim groupPointer As Long: groupPointer = 1
For i = 1 To top5PercentCount
If groupBigCaseCount(groupPointer) > 0 Then
' 分配这个大额案件
Dim bigCaseRow As Long: bigCaseRow = caseList(i, 1)
Dim bigCaseNo As String: bigCaseNo = caseList(i, 2)
Dim bigCaseAmount As Double: bigCaseAmount = caseList(i, 3)
' 标记这个大额案件已分配
caseList(i, 1) = -caseList(i, 1) ' 用负数标记已分配
' 记录到小组
groups(groupPointer, 4) = groups(groupPointer, 4) + 1
groups(groupPointer, 6) = groups(groupPointer, 6) + bigCaseAmount
If groups(groupPointer, 7) = "" Then
groups(groupPointer, 7) = bigCaseNo
groups(groupPointer, 8) = CStr(bigCaseAmount)
Else
groups(groupPointer, 7) = groups(groupPointer, 7) & "|" & bigCaseNo
groups(groupPointer, 8) = groups(groupPointer, 8) & "|" & CStr(bigCaseAmount)
End If
groupBigCaseCount(groupPointer) = groupBigCaseCount(groupPointer) - 1
bigCaseIndex = bigCaseIndex + 1
End If
' 移动到下一组
groupPointer = groupPointer + 1
If groupPointer > groupCount Then groupPointer = 1
' 检查是否所有组的大额案件都已分配完
Dim allBigCasesAssigned As Boolean: allBigCasesAssigned = True
For j = 1 To groupCount
If groupBigCaseCount(j) > 0 Then
allBigCasesAssigned = False
Exit For
End If
Next j
If allBigCasesAssigned Then Exit For
Next i
' 第四步:分配剩余案件(原代码原理,确保金额均衡)
' 计算各组剩余目标
Dim groupRemainingTarget() As Long
ReDim groupRemainingTarget(1 To groupCount)
Dim groupRemainingAmount() As Double
ReDim groupRemainingAmount(1 To groupCount)
For i = 1 To groupCount
groupRemainingTarget(i) = groups(i, 3) - groups(i, 4)
groupRemainingAmount(i) = (totalAmount * groups(i, 2)) - groups(i, 6)
Next i
' 创建剩余案件列表(排除已分配的大额案件)
Dim remainingCaseList() As Variant
ReDim remainingCaseList(1 To caseCount - bigCaseIndex, 1 To 3)
Dim remainingCaseCount As Long: remainingCaseCount = 0
For i = 1 To caseCount
If caseList(i, 1) > 0 Then ' 只取未分配的案件
remainingCaseCount = remainingCaseCount + 1
remainingCaseList(remainingCaseCount, 1) = caseList(i, 1)
remainingCaseList(remainingCaseCount, 2) = caseList(i, 2)
remainingCaseList(remainingCaseCount, 3) = caseList(i, 3)
End If
Next i
' 按金额降序排序剩余案件
Call QuickSortByAmount(remainingCaseList, 1, remainingCaseCount)
' 分配剩余案件(采用原代码的金额均衡策略)
Dim remainingCasePointer As Long: remainingCasePointer = 1
Do While remainingCasePointer <= remainingCaseCount
' 找到最需要案件的组(金额偏差最大)
Dim mostNeededGroup As Long: mostNeededGroup = 0
Dim maxNeedValue As Double: maxNeedValue = -9999999
For i = 1 To groupCount
If groupRemainingTarget(i) > 0 Then ' 还需要案件
Dim needValue As Double
If groupRemainingAmount(i) > 0 Then
needValue = groupRemainingAmount(i) / (totalAmount * groups(i, 2))
Else
needValue = 0
End If
If needValue > maxNeedValue Then
maxNeedValue = needValue
mostNeededGroup = i
End If
End If
Next i
If mostNeededGroup = 0 Then Exit Do
' 为这个组找到最合适的案件
Dim bestRemainingCaseIdx As Long: bestRemainingCaseIdx = -1
Dim bestRemainingAmount As Double: bestRemainingAmount = 0
Dim minRemainingDiff As Double: minRemainingDiff = 9999999
For i = remainingCasePointer To remainingCaseCount
Dim caseAmt As Double: caseAmt = remainingCaseList(i, 3)
Dim groupCurrentAmt As Double: groupCurrentAmt = groups(mostNeededGroup, 6)
Dim groupTargetAmt As Double: groupTargetAmt = totalAmount * groups(mostNeededGroup, 2)
' 计算金额差异
Dim amountDiffRem As Double
If groupTargetAmt > 0 Then
amountDiffRem = Abs((groupCurrentAmt + caseAmt) - groupTargetAmt) / groupTargetAmt
Else
amountDiffRem = 0
End If
If amountDiffRem < minRemainingDiff Then
minRemainingDiff = amountDiffRem
bestRemainingCaseIdx = i
bestRemainingAmount = caseAmt
End If
Next i
If bestRemainingCaseIdx > 0 Then
' 分配案件
Dim remCaseRow As Long: remCaseRow = remainingCaseList(bestRemainingCaseIdx, 1)
Dim remCaseNo As String: remCaseNo = remainingCaseList(bestRemainingCaseIdx, 2)
Dim remCaseAmt As Double: remCaseAmt = remainingCaseList(bestRemainingCaseIdx, 3)
' 记录到小组
groups(mostNeededGroup, 4) = groups(mostNeededGroup, 4) + 1
groups(mostNeededGroup, 6) = groups(mostNeededGroup, 6) + remCaseAmt
If groups(mostNeededGroup, 7) = "" Then
groups(mostNeededGroup, 7) = remCaseNo
groups(mostNeededGroup, 8) = CStr(remCaseAmt)
Else
groups(mostNeededGroup, 7) = groups(mostNeededGroup, 7) & "|" & remCaseNo
groups(mostNeededGroup, 8) = groups(mostNeededGroup, 8) & "|" & CStr(remCaseAmt)
End If
' 更新剩余目标
groupRemainingTarget(mostNeededGroup) = groupRemainingTarget(mostNeededGroup) - 1
groupRemainingAmount(mostNeededGroup) = groupRemainingAmount(mostNeededGroup) - remCaseAmt
' 从剩余列表中移除案件
If bestRemainingCaseIdx <> remainingCasePointer Then
Dim tempRow2 As Long: tempRow2 = remainingCaseList(bestRemainingCaseIdx, 1)
Dim tempNo2 As String: tempNo2 = remainingCaseList(bestRemainingCaseIdx, 2)
Dim tempAmt2 As Double: tempAmt2 = remainingCaseList(bestRemainingCaseIdx, 3)
remainingCaseList(bestRemainingCaseIdx, 1) = remainingCaseList(remainingCasePointer, 1)
remainingCaseList(bestRemainingCaseIdx, 2) = remainingCaseList(remainingCasePointer, 2)
remainingCaseList(bestRemainingCaseIdx, 3) = remainingCaseList(remainingCasePointer, 3)
remainingCaseList(remainingCasePointer, 1) = tempRow2
remainingCaseList(remainingCasePointer, 2) = tempNo2
remainingCaseList(remainingCasePointer, 3) = tempAmt2
End If
remainingCasePointer = remainingCasePointer + 1
Else
Exit Do
End If
Loop
' 第五步:计算调解员目标(基于小组的精确分配)
' 先统计每个组的信息
Dim groupInfo As Object
Set groupInfo = CreateObject("Scripting.Dictionary")
For i = 1 To mCount
Dim gName As String: gName = mediators(i, 4)
If Not groupInfo.Exists(gName) Then
Dim info(1 To 3) As Variant
info(1) = 0 ' 总明确比例
info(2) = 0 ' 均分人数
info(3) = 0 ' 总人数
groupInfo.Add gName, info
End If
Dim gInfo As Variant
gInfo = groupInfo(gName)
If mediators(i, 3) > 0 Then
gInfo(1) = gInfo(1) + mediators(i, 3)
ElseIf mediators(i, 3) = -1 Then
gInfo(2) = gInfo(2) + 1
End If
gInfo(3) = gInfo(3) + 1
groupInfo(gName) = gInfo
Next i
' 为每个调解员计算目标
For i = 1 To mCount
Dim currentGroup As String: currentGroup = mediators(i, 4)
' 找到对应小组的信息
Dim groupTargetCases2 As Long: groupTargetCases2 = 0
Dim groupTargetAmount2 As Double: groupTargetAmount2 = 0
For j = 1 To groupCount
If groups(j, 1) = currentGroup Then
groupTargetCases2 = groups(j, 3)
groupTargetAmount2 = groups(j, 6) ' 使用实际分配金额
Exit For
End If
Next j
' 计算个人比例
Dim gInfo2 As Variant: gInfo2 = groupInfo(currentGroup)
Dim personalRatio As Double
If mediators(i, 3) > 0 Then
' 有明确比例
personalRatio = mediators(i, 3) / gInfo2(1)
ElseIf mediators(i, 3) = -1 Then
' 均分
If gInfo2(2) > 0 Then
personalRatio = (1 - gInfo2(1)) / gInfo2(2)
Else
personalRatio = 1# / gInfo2(3)
End If
Else
personalRatio = 0
End If
' 设置调解员目标(四舍五入)
mediators(i, 7) = Round(groupTargetCases2 * personalRatio)
mediators(i, 8) = groupTargetAmount2 * personalRatio
' 确保至少分配一个案件
If mediators(i, 7) = 0 And groupTargetCases2 > 0 Then
mediators(i, 7) = 1
End If
Next i
' 调整调解员目标,确保与小组总数匹配
Dim dictKey As Variant
Dim gName2 As String
For Each dictKey In groupInfo
gName2 = CStr(dictKey)
Dim groupTotalTargetCases As Long: groupTotalTargetCases = 0
Dim groupTotalTargetAmount As Double: groupTotalTargetAmount = 0
' 收集这个组的所有调解员
Dim groupMedIndices() As Long
ReDim groupMedIndices(1 To mCount)
Dim gmCount As Long: gmCount = 0
For i = 1 To mCount
If mediators(i, 4) = gName2 Then
gmCount = gmCount + 1
groupMedIndices(gmCount) = i
groupTotalTargetCases = groupTotalTargetCases + mediators(i, 7)
groupTotalTargetAmount = groupTotalTargetAmount + mediators(i, 8)
End If
Next i
' 找到小组的实际目标
Dim actualGroupCases As Long: actualGroupCases = 0
Dim actualGroupAmount As Double: actualGroupAmount = 0
For j = 1 To groupCount
If groups(j, 1) = gName2 Then
actualGroupCases = groups(j, 3)
actualGroupAmount = groups(j, 6)
Exit For
End If
Next j
' 调整案件数
If groupTotalTargetCases <> actualGroupCases And gmCount > 0 Then
Dim caseDiff As Long: caseDiff = actualGroupCases - groupTotalTargetCases
If caseDiff > 0 Then
' 增加案件:按目标金额比例分配给调解员
For k = 1 To caseDiff
Dim minTargetIdx As Long: minTargetIdx = -1
Dim minTargetVal As Long: minTargetVal = 999999
For i = 1 To gmCount
Dim medIdx As Long: medIdx = groupMedIndices(i)
If mediators(medIdx, 7) < minTargetVal Then
minTargetVal = mediators(medIdx, 7)
minTargetIdx = medIdx
End If
Next i
If minTargetIdx > 0 Then
mediators(minTargetIdx, 7) = mediators(minTargetIdx, 7) + 1
End If
Next k
ElseIf caseDiff < 0 Then
' 减少案件:从目标数多的开始减
For k = 1 To Abs(caseDiff)
Dim maxTargetIdx As Long: maxTargetIdx = -1
Dim maxTargetVal As Long: maxTargetVal = 0
For i = 1 To gmCount
Dim medIdx2 As Long: medIdx2 = groupMedIndices(i)
If mediators(medIdx2, 7) > maxTargetVal And mediators(medIdx2, 7) > 1 Then
maxTargetVal = mediators(medIdx2, 7)
maxTargetIdx = medIdx2
End If
Next i
If maxTargetIdx > 0 Then
mediators(maxTargetIdx, 7) = mediators(maxTargetIdx, 7) - 1
End If
Next k
End If
End If
Next dictKey
' 第六步:将小组案件分配给调解员(确保金额均衡)
' 先将小组案件和金额拆分为数组
Dim groupCaseArrays() As Variant
ReDim groupCaseArrays(1 To groupCount)
Dim groupAmountArrays() As Variant
ReDim groupAmountArrays(1 To groupCount)
For i = 1 To groupCount
If groups(i, 7) <> "" Then
groupCaseArrays(i) = Split(groups(i, 7), "|")
groupAmountArrays(i) = Split(groups(i, 8), "|")
Else
groupCaseArrays(i) = Array()
groupAmountArrays(i) = Array()
End If
Next i
' 为每个组分配案件到调解员
For i = 1 To groupCount
If groups(i, 7) = "" Or groups(i, 7) = "0" Then GoTo NextGroupMedAllocation
' 找到这个组的所有调解员
Dim groupMediators2() As Long
ReDim groupMediators2(1 To mCount)
Dim mediatorCount As Long: mediatorCount = 0
For j = 1 To mCount
If mediators(j, 4) = groups(i, 1) Then
mediatorCount = mediatorCount + 1
groupMediators2(mediatorCount) = j
End If
Next j
If mediatorCount = 0 Then GoTo NextGroupMedAllocation
' 获取这个组的案件数组
Dim currentGroupCases() As String: currentGroupCases = groupCaseArrays(i)
Dim currentGroupAmounts() As String: currentGroupAmounts = groupAmountArrays(i)
Dim caseCountInGroup As Long: caseCountInGroup = UBound(currentGroupCases) - LBound(currentGroupCases) + 1
' 为调解员分配案件(确保金额均衡)
Dim groupCasePointer As Long: groupCasePointer = 0
Dim groupMedPointer As Long: groupMedPointer = 1
Do While groupCasePointer < caseCountInGroup
Dim currentMedIdx As Long: currentMedIdx = groupMediators2(groupMedPointer)
' 检查这个调解员是否还需要案件
If mediators(currentMedIdx, 5) < mediators(currentMedIdx, 7) Then
' 找到最适合这个调解员的案件
Dim bestCaseForMed As Long: bestCaseForMed = -1
Dim bestAmountForMed As Double: bestAmountForMed = 0
Dim minMedDiff As Double: minMedDiff = 9999999
For k = groupCasePointer To caseCountInGroup - 1
Dim candidateAmount As Double
If IsNumeric(currentGroupAmounts(k)) Then
candidateAmount = CDbl(currentGroupAmounts(k))
Else
candidateAmount = 0
End If
Dim medCurrentAmount As Double: medCurrentAmount = mediators(currentMedIdx, 6)
Dim medTargetAmount As Double: medTargetAmount = mediators(currentMedIdx, 8)
' 计算金额偏差
Dim medDiff As Double
If medTargetAmount > 0 Then
medDiff = Abs((medCurrentAmount + candidateAmount) - medTargetAmount) / medTargetAmount
Else
medDiff = 0
End If
If medDiff < minMedDiff Then
minMedDiff = medDiff
bestCaseForMed = k
bestAmountForMed = candidateAmount
End If
Next k
If bestCaseForMed >= 0 Then
' 找到案件对应的行号
Dim targetCaseNo As String: targetCaseNo = currentGroupCases(bestCaseForMed)
Dim foundRow As Long: foundRow = 0
For k = 1 To caseCount
If caseList(k, 2) = targetCaseNo Then
foundRow = Abs(caseList(k, 1)) ' 取绝对值(之前用负数标记过大额案件)
Exit For
End If
Next k
If foundRow > 0 Then
' 分配案件
wsCases.Cells(foundRow, 3).Value = mediators(currentMedIdx, 2)
' 更新调解员状态
mediators(currentMedIdx, 5) = mediators(currentMedIdx, 5) + 1
mediators(currentMedIdx, 6) = mediators(currentMedIdx, 6) + bestAmountForMed
If mediators(currentMedIdx, 9) = "" Then
mediators(currentMedIdx, 9) = targetCaseNo
Else
mediators(currentMedIdx, 9) = mediators(currentMedIdx, 9) & "," & targetCaseNo
End If
' 从小组列表中移除这个案件
If bestCaseForMed <> groupCasePointer Then
' 交换位置
Dim tempCaseName As String: tempCaseName = currentGroupCases(bestCaseForMed)
Dim tempAmountStr As String: tempAmountStr = currentGroupAmounts(bestCaseForMed)
currentGroupCases(bestCaseForMed) = currentGroupCases(groupCasePointer)
currentGroupAmounts(bestCaseForMed) = currentGroupAmounts(groupCasePointer)
currentGroupCases(groupCasePointer) = tempCaseName
currentGroupAmounts(groupCasePointer) = tempAmountStr
End If
groupCasePointer = groupCasePointer + 1
End If
End If
End If
' 移动到下一个调解员
groupMedPointer = groupMedPointer + 1
If groupMedPointer > mediatorCount Then groupMedPointer = 1
' 检查是否所有调解员都已满
Dim allMedFull As Boolean: allMedFull = True
For k = 1 To mediatorCount
Dim medIdx3 As Long: medIdx3 = groupMediators2(k)
If mediators(medIdx3, 5) < mediators(medIdx3, 7) Then
allMedFull = False
Exit For
End If
Next k
If allMedFull Or groupCasePointer >= caseCountInGroup Then Exit Do
Loop
NextGroupMedAllocation:
Next i
' 第七步:输出优化报告
Dim msg As String
msg = "?? 优化版双重均衡分配完成 (" & Format(Timer - startTime, "0.00") & "秒)" & vbCrLf & vbCrLf
msg = msg & "?? 精确统计:" & vbCrLf
msg = msg & " 总案件数: " & caseCount & " 件" & vbCrLf
msg = msg & " 总金额: ¥" & Format(totalAmount, "#,##0.00") & vbCrLf
msg = msg & " 前5%大额案件数: " & top5PercentCount & " 件(已均分到各组)" & vbCrLf & vbCrLf
msg = msg & "?? 小组分配结果(大额案件均分 + 金额均衡):" & vbCrLf
Dim totalCaseError As Double: totalCaseError = 0
Dim totalAmtError As Double: totalAmtError = 0
' 计算大额案件分布
Dim bigCaseDistribution As String: bigCaseDistribution = "大额案件分布: "
For i = 1 To groupCount
' 统计每个组的大额案件数
Dim bigCasesInGroup As Long: bigCasesInGroup = 0
If groups(i, 7) <> "" Then
Dim casesArray() As String
casesArray = Split(groups(i, 7), "|")
Dim amountsArray() As String
amountsArray = Split(groups(i, 8), "|")
' 统计前top5PercentCount个大额案件
For j = 0 To UBound(casesArray)
If j < UBound(casesArray) + 1 Then
For k = 1 To top5PercentCount
If k <= caseCount Then
If casesArray(j) = caseList(k, 2) Then
bigCasesInGroup = bigCasesInGroup + 1
Exit For
End If
End If
Next k
End If
Next j
End If
bigCaseDistribution = bigCaseDistribution & groups(i, 1) & ":" & bigCasesInGroup & "件 "
Next i
msg = msg & " " & bigCaseDistribution & vbCrLf & vbCrLf
For i = 1 To groupCount
Dim targetCasePct As Double: targetCasePct = groups(i, 2) * 100
Dim actualCasePct As Double
If caseCount > 0 Then
actualCasePct = groups(i, 4) / caseCount * 100
Else
actualCasePct = 0
End If
Dim targetAmtPct As Double: targetAmtPct = groups(i, 2) * 100
Dim actualAmtPct As Double
If totalAmount > 0 Then
actualAmtPct = groups(i, 6) / totalAmount * 100
Else
actualAmtPct = 0
End If
Dim caseError As Double: caseError = actualCasePct - targetCasePct
Dim amtError As Double: amtError = actualAmtPct - targetAmtPct
totalCaseError = totalCaseError + Abs(caseError)
totalAmtError = totalAmtError + Abs(amtError)
msg = msg & " " & groups(i, 1) & ":" & vbCrLf
msg = msg & " 目标: " & Format(targetCasePct, "0.0000") & "% 案件, " & Format(targetAmtPct, "0.0000") & "% 金额" & vbCrLf
msg = msg & " 实际: " & groups(i, 4) & "件 (" & Format(actualCasePct, "0.0000") & "%)" & _
" ¥" & Format(groups(i, 6), "#,##0.00") & " (" & Format(actualAmtPct, "0.0000") & "%)" & vbCrLf
If Abs(caseError) < 0.1 And Abs(amtError) < 0.1 Then
msg = msg & " ? 完美匹配(误差 < 0.1%)" & vbCrLf
ElseIf Abs(caseError) < 0.5 And Abs(amtError) < 0.5 Then
msg = msg & " ? 高度精确(误差 < 0.5%)" & vbCrLf
ElseIf Abs(caseError) < 1 And Abs(amtError) < 1 Then
msg = msg & " ?? 基本精确(误差 < 1%)" & vbCrLf
Else
msg = msg & " ? 存在偏差: 案件" & Format(caseError, "+0.0000;-0.0000") & "%, "
msg = msg & "金额" & Format(amtError, "+0.0000;-0.0000") & "%" & vbCrLf
End If
Next i
' 调解员金额均衡性分析
msg = msg & vbCrLf & "?? 调解员金额均衡性:" & vbCrLf
Dim shownGroups As Object
Set shownGroups = CreateObject("Scripting.Dictionary")
Dim totalMediatorBalance As Double: totalMediatorBalance = 0
Dim mediatorBalanceCount As Long: mediatorBalanceCount = 0
For i = 1 To mCount
Dim medGroup As String: medGroup = mediators(i, 4)
If Not shownGroups.Exists(medGroup) Then
msg = msg & vbCrLf & " 【" & medGroup & "】" & vbCrLf
shownGroups.Add medGroup, True
End If
Dim medCaseCompletion As Double: medCaseCompletion = 0
Dim medAmtCompletion As Double: medAmtCompletion = 0
If mediators(i, 7) > 0 Then medCaseCompletion = mediators(i, 5) / mediators(i, 7) * 100
If mediators(i, 8) > 0 Then medAmtCompletion = mediators(i, 6) / mediators(i, 8) * 100
Dim medBalanceDiff As Double: medBalanceDiff = Abs(medCaseCompletion - medAmtCompletion)
totalMediatorBalance = totalMediatorBalance + medBalanceDiff
mediatorBalanceCount = mediatorBalanceCount + 1
msg = msg & " " & mediators(i, 2) & ":" & vbCrLf
msg = msg & " 目标: " & mediators(i, 7) & "案, ¥" & Format(mediators(i, 8), "#,##0.00") & vbCrLf
msg = msg & " 实际: " & mediators(i, 5) & "案 (" & Format(medCaseCompletion, "0.00") & "%)" & _
" ¥" & Format(mediators(i, 6), "#,##0.00") & " (" & Format(medAmtCompletion, "0.00") & "%)" & vbCrLf
If medBalanceDiff < 5 Then
msg = msg & " ? 金额均衡(差" & Format(medBalanceDiff, "0.0") & "%)" & vbCrLf
ElseIf medBalanceDiff < 10 Then
msg = msg & " ?? 基本均衡(差" & Format(medBalanceDiff, "0.0") & "%)" & vbCrLf
Else
msg = msg & " ? 不均衡(差" & Format(medBalanceDiff, "0.0") & "%)" & vbCrLf
End If
Next i
' 精度总结
Dim avgCaseError2 As Double: avgCaseError2 = totalCaseError / groupCount
Dim avgAmtError2 As Double: avgAmtError2 = totalAmtError / groupCount
Dim avgBalanceError As Double
If mediatorBalanceCount > 0 Then
avgBalanceError = totalMediatorBalance / mediatorBalanceCount
Else
avgBalanceError = 0
End If
msg = msg & vbCrLf & "?? 优化分配总结:" & vbCrLf
msg = msg & " 小组案件平均误差: " & Format(avgCaseError2, "0.0000") & "%" & vbCrLf
msg = msg & " 小组金额平均误差: " & Format(avgAmtError2, "0.0000") & "%" & vbCrLf
msg = msg & " 调解员金额均衡度: " & Format(avgBalanceError, "0.00") & "%" & vbCrLf & vbCrLf
If avgCaseError2 < 0.1 And avgAmtError2 < 0.1 And avgBalanceError < 5 Then
msg = msg & " ?? 综合评价: 完美双重均衡分配!"
ElseIf avgCaseError2 < 0.5 And avgAmtError2 < 0.5 And avgBalanceError < 10 Then
msg = msg & " ? 综合评价: 优秀均衡分配"
ElseIf avgCaseError2 < 1 And avgAmtError2 < 1 And avgBalanceError < 20 Then
msg = msg & " ?? 综合评价: 合格均衡分配"
Else
msg = msg & " ? 综合评价: 需要进一步优化"
End If
MsgBox msg, vbInformation, "优化版双重均衡分配报告"
CleanUp:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Exit Sub
ErrorHandler:
MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical, "运行失败"
Resume CleanUp
End Sub
' =============================================================================
' ?? 辅助函数区
' =============================================================================
Sub QuickSortByAmount(arr As Variant, low As Long, high As Long)
If low >= high Then Exit Sub
Dim i As Long, j As Long, pivot As Double
Dim tempRow As Long, tempNo As String, tempAmt As Double
i = low: j = high
pivot = arr((low + high) \ 2, 3)
Do While i <= j
Do While arr(i, 3) > pivot: i = i + 1: Loop
Do While arr(j, 3) < pivot: j = j - 1: Loop
If i <= j Then
tempRow = arr(i, 1): tempNo = arr(i, 2): tempAmt = arr(i, 3)
arr(i, 1) = arr(j, 1): arr(i, 2) = arr(j, 2): arr(i, 3) = arr(j, 3)
arr(j, 1) = tempRow: arr(j, 2) = tempNo: arr(j, 3) = tempAmt
i = i + 1: j = j - 1
End If
Loop
If low < j Then QuickSortByAmount arr, low, j
If i < high Then QuickSortByAmount arr, i, high
End Sub
Sub SortByDecimalDesc(arr As Variant, low As Long, high As Long)
If low >= high Then Exit Sub
Dim i As Long, j As Long, pivot As Double
Dim temp As Variant
i = low: j = high
pivot = arr((low + high) \ 2)(1)
Do While i <= j
Do While arr(i)(1) > pivot: i = i + 1: Loop
Do While arr(j)(1) < pivot: j = j - 1: Loop
If i <= j Then
temp = arr(i): arr(i) = arr(j): arr(j) = temp
i = i + 1: j = j - 1
End If
Loop
If low < j Then SortByDecimalDesc arr, low, j
If i < high Then SortByDecimalDesc arr, i, high
End Sub
这个的分配结果就是我比较满意的 但是最后的金额差异和理论的差的有点多 所以我需要优化 给我一个优化的VBA 和py代码