调停者模式(mediators)

本文通过一个宫廷故事,深入浅出地介绍了迪米特法则的基本概念及其在软件设计中的应用。探讨了如何通过减少类之间的直接交互来降低耦合度,并分析了其优缺点。

     有一段时间没写过blog,今天没什么事情,看了看,jy里很多关于调停者设计模式的,打算自己也整理下,也算为自己加深下印象:


     前言:

     要了解调停者模式,先看看一个比较著名的法则:——迪米特法则


      迪米特法则(Law of Demeter)又叫作最少知识原则(Least Knowledge Principle 简写LKP),就是说一个对象应当对其他对象有尽可能少的了解,不和陌生人说话。英文简写为: LoD.

 

  迪米特法则可以简单说成:talk only to your immediate friends。 对于面向OOD来说,又被解释为下面几种方式:一个软件实体应当尽可能少的与其他实体发生相互作用。每一个软件单位对其他的单位都只有最少的知识,而且局限于那些与本单位密切相关的软件单位。

  迪米特法则的初衷在于降低类之间的耦合。由于每个类尽量减少对其他类的依赖,因此,很容易使得系统的功能模块功能独立,相互之间不存在(或很少有)依赖关系。

  迪米特法则不希望类直接建立直接的接触。如果真的有需要建立联系,也希望能通过它的友元类来转达。因此,应用迪米特法则有可能造成的一个后果就是:系统中存在大量的中介类,这些类之所以存在完全是为了传递类之间的相互调用关系——这在一定程度上增加了系统的复杂度。

    狭义的迪米特法则是指:如果两个类不必彼此直接通信,那么这两个类就不应当发生直接的相互作用。如果其中一个类需要调用另一类的某一个方法的话,可以通过第三者转发这个调用。

 

 

      广义的迪米特法则是指:一个模块设计的好坏的一个重要标志就是该模块在多大程度上讲自己的内部数据与实现的有关细节隐藏起来。

      一个软件实体应当尽可能少的与其他实体发生相互作用。

      每一个软件单位对其他的单位都只有最少的知识,而且局限于那些与本单位密切相关的软件单位。

      迪米特法则的目的在于降低类与类之间的耦合。由于每个类尽量减少对其他类的依赖,因此,很容易使得系统的功能模块功能独立,是的相互间存在尽可能少的依赖关系。

 

在运用迪米特法则到系统的设计中时,要注意以下几点:

第一:在类的划分上,应当创建弱耦合的类,类与类之间的耦合越弱,就越有利于实现可复用的目标。

第二:在类的结构设计上,每个类都应该降低成员的访问权限。

第三:在类的设计上,只要有可能,一个类应当设计成不变的类。

第四:在对其他类的应用上,一个对象对其他类的对象的应用应该降到最低。

第五:尽量限制局部变量的有效范围。

 

但是过度使用迪米特法则,也会造成系统的不同模块之间的通信效率降低,使系统的不同模块之间不容易协调等缺点。同时,因为迪米特法则要求类与类之间尽量不直接通信,如果类之间需要通信就通过第三方转发的方式,这就直接导致了系统中存在大量的中介类,这些类存在的唯一原因是为了传递类与类之间的相互调用关系,这就毫无疑问的增加了系统的复杂度。解决这个问题的方式是:使用依赖倒转原则(通俗的讲就是要针对接口编程,不要针对具体编程),这要就可以是调用方和被调用方之间有了一个抽象层,被调用方在遵循抽象层的前提下就可以自由的变化,此时抽象层成了调用方的朋友。

Demo (出自国士工作室)

 

 

故事分析: 

       慈禧太后要召见庞青龙。庞青龙在见到慈禧太后前经历了那些过程呢?首先,当然是有人通知庞青龙要被召见,通知庞青龙的人当然不会是慈禧本人!慈禧只是下达旨意,然后又相关的只能部门传达旨意,相关部门的领导人也不会亲自去通知庞青龙,这些领导人会派遣信得过的人去,而这个被派遣的人也不是说想见庞青龙就能见得了的,他也必须通过和庞青龙熟悉的人,最后才能见到庞青龙,从而才能成功的传达旨意;第二:在进宫前,庞青龙必须卸掉自己随身携带的任何武器;第三:会有专门的只能部门对庞青龙进行全身彻底的检查,以防有任何可以伤害人的东西携带在身上,当然这个过程可能非常的复杂和繁琐。最后,由一个太监带路到慈禧面前。当然,见到慈禧的时候,庞青龙不是和慈禧坐在一起的,要报仇距离!慈禧也深深的懂得保持距离的重要性!

       见到慈禧太后以后慈禧也没有和庞青龙直接说话,因为慈禧不和陌生人说话!而是同时身边的人传达自己的话,慈禧只需颐指气使即可。

       从上面的过程中我们可以看出处处体现了迪米特法则的应用,慈禧知道庞青龙这个人肯定是通过一层又一层的关系得知的,就是迪米特法则中的第三者转发而且这里面说不定还有若干个第三者的转发!而从慈溪下旨召见庞青龙到庞青龙收到旨意,这中间又是完美的提现了迪米特法则,这中间经历无数的第三者!就连庞青龙面见到慈禧后,慈禧也不和他直接说话,而是通过身边的人传话,这慈禧是不是太傻了,直接和他说不就行了吗?慈禧当然不傻,因为她深知迪米特法则的重要。两个类的对象之间如果不发生直接的联系就不直接发生关系!

       不过这也产生了一个问题,这中间经历这么多的转发,需要机构和人啊?或许这就是为什么当时的清政府机构那么庞大、财政开支惊人的原因之一吧^_^

如下图所示:

 新建一个陌生人的抽象父类,其他的陌生人继承这个接口:

package com.diermeng.designPattern.LoD;
/*
 * 抽象的陌生人类
 */
public abstract class Stranger {
    /*
     * 抽象的行为方法
     */
    public abstract void operation();
}
 

庞青龙实现继承实现陌生人抽象类:

package com.diermeng.designPattern.LoD.impl;
 
import com.diermeng.designPattern.LoD.Stranger;
/*
 * 庞青龙对抽象类Stranger的实现
 */
public class PangQingyong extends Stranger{
    /*
     * 操作方法
     * @see com.diermeng.designPattern.LoD.Stranger#operation()
     */
    public void operation(){
        System.out.println("禀报太后:我是庞青龙,我擅长用兵打仗!");
    }
}
 
 
 

   朋友类,这里指太监类

package com.diermeng.designPattern.LoD.impl;
 
import com.diermeng.designPattern.LoD.Stranger;
/*
 * 太监类
 */
public class Taijian {
    /*
     * 太监类的操作方法
     */
    public void operation(){
        System.out.println("friends paly");
    }
 
    /*
     * 由太监类提供Cixi需要的方法
     */
    public void findStranger() {
        //创建一个Stranger
        Stranger stranger = new PangQingyong();
        //执行相应的方法
        stranger.operation();
    }
}
 
 

 调用者类的代码,在这里是慈禧太后类:

package com.diermeng.designPattern.LoD.impl;
 
/*
 * 慈禧类
 */
public class Cixi {
    //拥有对太监的引用,即对“朋友”的引用
    private Taijian taijian;
 
    //得到一个太监对象
    public Taijian getTaijian() {
        return taijian;
    }
 
    //设置一个太监对象
    public void setTaijian(Taijian taijian) {
        this.taijian = taijian;
    }
 
    //操作方法
    public void operation(){
        System.out.println("someone play");
    }
 
 
}
 

 建立一个测试类,代码如下:

package com.diermeng.designPattern.LoD.client;
 
import com.diermeng.designPattern.LoD.impl.Taijian;
import com.diermeng.designPattern.LoD.impl.Cixi;
 
/*
 * 测试客户端
 */
public class LoDTest {
 
    public static void main(String[] args) {
        //声明并实例化慈禧类
        Cixi zhangsan = new Cixi();
 
        //设置一个太监实例化对象,即找到一个“朋友”帮忙做事
        zhangsan.setTaijian(new Taijian());
 
        //慈禧通过宫中太监传话给陌生人
        zhangsan.getTaijian().findStranger();
    }
}
 

 程序运行结果如下:

禀报太后:我是庞青龙,我擅长用兵打仗!
 已有应用简介: 

       迪米特法则或者最少知识原则作为面向对象设计风格的一种法则,也是很多著名软件设计系统的指导原则,比如火星登陆软件系统、木星的欧罗巴卫星轨道飞船软件系统。

温馨提示: 

迪米特法则是一种面向对象系统设计风格的一种法则,尤其适合做大型复杂系统设计指导原则。但是也会造成系统的不同模块之间的通信效率降低,使系统的不同模块之间不容易协调等缺点。同时,因为迪米特法则要求类与类之间尽量不直接通信,如果类之间需要通信就通过第三方转发的方式,这就直接导致了系统中存在大量的中介类,这些类存在的唯一原因是为了传递类与类之间的相互调用关系,这就毫无疑问的增加了系统的复杂度。解决这个问题的方式是:使用依赖倒转原则(通俗的讲就是要针对接口编程,不要针对具体编程),这要就可以是调用方和被调用方之间有了一个抽象层,被调用方在遵循抽象层的前提下就可以自由的变化,此时抽象层成了调用方的朋友。

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代码
12-18
评论
成就一亿技术人!
拼手气红包6.0元
还能输入1000个字符
 
红包 添加红包
表情包 插入表情
 条评论被折叠 查看
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值