2018元旦我的第一帖：网络最大流算法之VBA实现

aoe1981

　　算法来源于图论教材，如下图：
　　

　　

　　

　　

　　

　　

　　我干了什么？
　　１.用VBA实现了该算法，算是习题；
　　２.创造性地用散点图实现了有向图、网络的直观演示；
　　３.书中算法只揭示了框架，具体数据处理、流程组织无参照，属原创；算法核心部分BFS广度搜索是我第一次尝试，我实现了利用两个字典生成“广度优先生成树”，这是我最核心的“原创”。
　　呵呵……

　　附件如下：
　　 网络最大流算法之VBA实现.zip (62.66 KB, 下载次数: 109)

2018-1-4 20:34 上传

点击文件名下载附件

　　（找到s-t点列后按算法应当提前退出遍历，已添加，已更新。详细说明见12楼。）

aoe1981

　　展示一下所有代码：
　　工作表Sheet1的事件代码：

1. Option Explicit
   
2. Private Sub Worksheet_Change(ByVal Target As Range)
   
3.     If Target.Address = Range("b1").Address Then
   
4.         Application.EnableEvents = False
   
5.         Dim i%, dian$(), r%, js%
   
6.         Union(Range("a19:e" & Rows.Count), Range("o2:u" & Rows.Count)).ClearContents
   
7.         n = Target.Value
   
8.         ReDim dian$(1 To n, 1 To 1)
   
9.         js = 1
   
10.         If n > 26 Then '生成点集V
    
11.             For i = 1 To n
    
12.                 r = (i - 1) Mod 26 + 1
    
13.                 If r = 26 Then js = js + 1
    
14.                 dian(i, 1) = Chr(96 + r) & js
    
15.             Next i
    
16.         Else
    
17.             For i = 1 To n
    
18.                 dian(i, 1) = Chr(96 + i)
    
19.             Next i
    
20.         End If
    
21.         Range("a19").Resize(n, 1).Value = dian
    
22.         Range("b2").Value = 1
    
23.         pd = 0
    
24.         Range("b14").Value = "否"
    
25.         Application.EnableEvents = True
    
26.     End If
    
27.     If Not (Target.Address = Range("b2").Address Or Target.Address = Range("b4").Address Or Target.Address = Range("b9").Address _
    
28.     Or Target.Address = Range("b14").Address Or Target.Address = Range("d11").Address Or Target.Address = Range("d12").Address) Then
    
29.         If pd = 2 Then pd = 0  '为保证第⑤步读入数据正确，如产生除设置有填充色单元格值的其他修改时，将强制从头再来
    
30.     End If
    
31. End Sub

复制代码

　　“成图”模块代码：

1. Option Explicit
   
2. Public n%, m%, pd%
   
3. Sub dian() '生成点坐标
   
4.     Sheet1.Activate
   
5.     Dim i%, lx$
   
6.     If n = 0 Then MsgBox "请先输入图的阶。": Range("b1").Select: Exit Sub
   
7.     Application.EnableEvents = False
   
8.     ReDim zb_dian#(1 To n, 1 To 2)
   
9.     Union(Range("b19:d" & Rows.Count), Range("o2:u" & Rows.Count)).ClearContents
   
10.     lx = Range("b4").Value
    
11.     Randomize
    
12.     For i = 1 To n
    
13.         If lx = "随机坐标" Then
    
14.             zb_dian(i, 1) = -10 + Rnd() * 20: zb_dian(i, 2) = -10 + Rnd() * 20
    
15.         Else
    
16.             zb_dian(i, 1) = 9 * Cos(2 * WorksheetFunction.Pi() / n * (i - 1) + 3 * WorksheetFunction.Pi() / 4)
    
17.             zb_dian(i, 2) = 9 * Sin(2 * WorksheetFunction.Pi() / n * (i - 1) + 3 * WorksheetFunction.Pi() / 4)
    
18.         End If
    
19.     Next i
    
20.     Range("b19").Resize(n, 2).Value = zb_dian
    
21.     pd = 1
    
22.     Range("b14").Value = "否"
    
23.     Application.EnableEvents = True
    
24. End Sub
    
25. Sub bian1() '随机生成有向边
    
26.     Sheet1.Activate
    
27.     m = Range("b2").Value
    
28.     If n = 0 Then MsgBox "请先输入图的阶。": Range("b1").Select: Exit Sub
    
29.     If pd = 0 Then MsgBox "请先生成点的坐标。": Range("b4").Select: Exit Sub
    
30.     Application.EnableEvents = False
    
31.     Union(Range("d19:e" & Rows.Count), Range("o2:u" & Rows.Count)).ClearContents
    
32.     Dim name_dian, name_bian$(), sc_bian(), i%, j%, js&, r&, gd, d_x As Object, d_y As Object, c&
    
33.     ReDim name_bian$(1 To n * (n - 1) / 2, 1 To 3), sc_bian(1 To m, 1 To 2)
    
34.     name_dian = Range("a19:c" & 18 + n).Value
    
35.     c = Range("b9").Value '容量最大值
    
36.     js = 0
    
37.     Set d_x = CreateObject("scripting.dictionary")
    
38.     Set d_y = CreateObject("scripting.dictionary")
    
39.     For i = 1 To n - 1 '生成所有边
    
40.         d_x(name_dian(i, 1)) = name_dian(i, 2): d_y(name_dian(i, 1)) = name_dian(i, 3) '点名称及坐标信息读入字典
    
41.         For j = i + 1 To n
    
42.             js = js + 1
    
43.             name_bian(js, 1) = name_dian(i, 1)
    
44.             name_bian(js, 2) = name_dian(j, 1)
    
45.         Next j
    
46.     Next i
    
47.     d_x(name_dian(n, 1)) = name_dian(n, 2): d_y(name_dian(n, 1)) = name_dian(i, 3)
    
48.     Randomize
    
49.     For i = 1 To js '随机乱序所有边
    
50.         r = Int(Rnd() * (js - i + 1)) + i
    
51.         gd = name_bian(r, 1): name_bian(r, 1) = name_bian(i, 1): name_bian(i, 1) = gd
    
52.         gd = name_bian(r, 2): name_bian(r, 2) = name_bian(i, 2): name_bian(i, 2) = gd
    
53.     Next i
    
54.     js = 0
    
55.     For i = 1 To m '抽取前m条边并随机指定方向
    
56.         name_bian(i, 3) = Int(Rnd() + 0.5) '1为→，0为←
    
57.         sc_bian(i, 1) = name_bian(i, 1) & IIf(name_bian(i, 3), "→", "←") & name_bian(i, 2)
    
58.         sc_bian(i, 2) = Int(Rnd() * c) + 1
    
59.         If name_bian(i, 3) Then '写入边
    
60.             Cells(i + 1 + js, "o").Value = name_bian(i, 1): Cells(i + 1 + js, "p").Value = d_x(name_bian(i, 1)): Cells(i + 1 + js, "q").Value = d_y(name_bian(i, 1))
    
61.             Cells(i + 2 + js, "o").Value = name_bian(i, 2): Cells(i + 2 + js, "p").Value = d_x(name_bian(i, 2)): Cells(i + 2 + js, "q").Value = d_y(name_bian(i, 2))
    
62.             Cells(i + 2 + js, "s").Value = sc_bian(i, 2)
    
63.             Cells(i + 1 + js, "t").Value = d_x(name_bian(i, 1)): Cells(i + 1 + js, "u").Value = d_y(name_bian(i, 1))
    
64.             Cells(i + 2 + js, "t").Value = (d_x(name_bian(i, 1)) + d_x(name_bian(i, 2))) / 2: Cells(i + 2 + js, "u").Value = (d_y(name_bian(i, 1)) + d_y(name_bian(i, 2))) / 2
    
65.         Else
    
66.             Cells(i + 1 + js, "o").Value = name_bian(i, 2): Cells(i + 1 + js, "p").Value = d_x(name_bian(i, 2)): Cells(i + 1 + js, "q").Value = d_y(name_bian(i, 2))
    
67.             Cells(i + 2 + js, "o").Value = name_bian(i, 1): Cells(i + 2 + js, "p").Value = d_x(name_bian(i, 1)): Cells(i + 2 + js, "q").Value = d_y(name_bian(i, 1))
    
68.             Cells(i + 2 + js, "s").Value = sc_bian(i, 2)
    
69.             Cells(i + 1 + js, "t").Value = d_x(name_bian(i, 2)): Cells(i + 1 + js, "u").Value = d_y(name_bian(i, 2))
    
70.             Cells(i + 2 + js, "t").Value = (d_x(name_bian(i, 2)) + d_x(name_bian(i, 1))) / 2: Cells(i + 2 + js, "u").Value = (d_y(name_bian(i, 2)) + d_y(name_bian(i, 1))) / 2
    
71.         End If
    
72.         js = js + 2
    
73.     Next i
    
74.     Range("d19").Resize(m, 2).Value = sc_bian
    
75.     pd = 2
    
76.     Range("b14").Value = "否"
    
77.     Application.EnableEvents = True
    
78. End Sub
    
79. Sub bian2() '添加手动调整有向边
    
80.     Sheet1.Activate
    
81.     m = Range("b2").Value
    
82.     If n = 0 Then MsgBox "请先输入图的阶。": Range("b1").Select: Exit Sub
    
83.     If pd = 0 Then MsgBox "请先生成点的坐标。": Range("b4").Select: Exit Sub
    
84.     Application.EnableEvents = False
    
85.     Union(Range("d19:d" & Rows.Count), Range("o2:u" & Rows.Count)).ClearContents
    
86.     Dim name_dian, name_bian(), sc_bian(), i%, j%, js&, r&, gd, d_x As Object, d_y As Object
    
87.     ReDim sc_bian(1 To m, 1 To 1)
    
88.     name_dian = Range("a19:c" & 18 + n).Value
    
89.     name_bian = Range("e19:h" & 18 + m).Value
    
90.     Set d_x = CreateObject("scripting.dictionary")
    
91.     Set d_y = CreateObject("scripting.dictionary")
    
92.     For i = 1 To n
    
93.         d_x(name_dian(i, 1)) = name_dian(i, 2): d_y(name_dian(i, 1)) = name_dian(i, 3) '点名称及坐标信息读入字典
    
94.     Next i
    
95.     For i = 1 To m '判断手动输入是否有空值，输入点是否存在，起点终点是否相同，边是否重复
    
96.         For j = 1 To 4
    
97.             If name_bian(i, j) = "" Then MsgBox "单元格：" & Cells(16 + i, 4 + j).Address & "数据未录入！": Cells(16 + i, 4 + j).Select: Exit Sub
    
98.         Next j
    
99.         If Not (d_x.exists(name_bian(i, 2))) Then MsgBox name_bian(i, 2) & "点不存在！": Cells(16 + i, 6).Select: Exit Sub
    
100.         If Not (d_x.exists(name_bian(i, 4))) Then MsgBox name_bian(i, 4) & "点不存在！": Cells(16 + i, 8).Select: Exit Sub
     
101.         If name_bian(i, 2) = name_bian(i, 4) Then MsgBox "起点与终点相同！": Union(Cells(16 + i, 6), Cells(16 + i, 8)).Select: Exit Sub
     
102.         For j = i + 1 To m
     
103.             If name_bian(i, 2) = name_bian(j, 2) And name_bian(i, 4) = name_bian(j, 4) Then
     
104.                 MsgBox "两边重复！": Union(Cells(16 + i, 6), Cells(16 + i, 8), Cells(16 + j, 6), Cells(16 + j, 8)).Select: Exit Sub
     
105.             End If
     
106.         Next j
     
107.     Next i
     
108.     js = 0
     
109.     For i = 1 To m
     
110.         sc_bian(i, 1) = name_bian(i, 2) & name_bian(i, 3) & name_bian(i, 4)
     
111.         If name_bian(i, 3) = "→" Then '写入边
     
112.             Cells(i + 1 + js, "o").Value = name_bian(i, 2): Cells(i + 1 + js, "p").Value = d_x(name_bian(i, 2)): Cells(i + 1 + js, "q").Value = d_y(name_bian(i, 2))
     
113.             Cells(i + 2 + js, "o").Value = name_bian(i, 4): Cells(i + 2 + js, "p").Value = d_x(name_bian(i, 4)): Cells(i + 2 + js, "q").Value = d_y(name_bian(i, 4))
     
114.             Cells(i + 2 + js, "s").Value = name_bian(i, 1) '写入容量显示数据标签
     
115.             Cells(i + 1 + js, "t").Value = d_x(name_bian(i, 2)): Cells(i + 1 + js, "u").Value = d_y(name_bian(i, 2))
     
116.             Cells(i + 2 + js, "t").Value = (d_x(name_bian(i, 2)) + d_x(name_bian(i, 4))) / 2: Cells(i + 2 + js, "u").Value = (d_y(name_bian(i, 2)) + d_y(name_bian(i, 4))) / 2
     
117.         Else
     
118.             Cells(i + 1 + js, "o").Value = name_bian(i, 4): Cells(i + 1 + js, "p").Value = d_x(name_bian(i, 4)): Cells(i + 1 + js, "q").Value = d_y(name_bian(i, 4))
     
119.             Cells(i + 2 + js, "o").Value = name_bian(i, 2): Cells(i + 2 + js, "p").Value = d_x(name_bian(i, 2)): Cells(i + 2 + js, "q").Value = d_y(name_bian(i, 2))
     
120.             Cells(i + 2 + js, "s").Value = name_bian(i, 1) '写入容量显示数据标签
     
121.             Cells(i + 1 + js, "t").Value = d_x(name_bian(i, 4)): Cells(i + 1 + js, "u").Value = d_y(name_bian(i, 4))
     
122.             Cells(i + 2 + js, "t").Value = (d_x(name_bian(i, 4)) + d_x(name_bian(i, 2))) / 2: Cells(i + 2 + js, "u").Value = (d_y(name_bian(i, 4)) + d_y(name_bian(i, 2))) / 2
     
123.         End If
     
124.         js = js + 2
     
125.     Next i
     
126.     Range("d19").Resize(m, 1).Value = sc_bian
     
127.     pd = 2
     
128.     Range("b14").Value = "否"
     
129.     Application.EnableEvents = True
     
130. End Sub

复制代码

　　装不下，下楼继续。

aoe1981

　　“计算”模块代码：

1. '本模块旨在写成独立于成图模块可单独拿出运行的代码，只要喂入正确的数据，包括：点集V、边集A、起点s、终点t、容量c
   
2. '但目前本模块的独立运行依赖于成图模块中的全局变量图的阶：n、图的规模m，所以不独立取值，是为了逻辑的严谨，防止错误数据造成程序中止
   
3. Option Explicit
   
4. Sub jisuan() '计算最大流
   
5.     Sheet1.Activate
   
6.     If Range("b14").Value = "否" Then
   
7.         If pd <> 2 Then MsgBox "请先完成第④步。": Exit Sub
   
8.     Else
   
9.         n = Range("b1").Value: m = Range("b2").Value
   
10.     End If
    
11.     Dim A_c As Object, A_f As Object, V_d As Object, V_ljd As Object, s$, t$
    
12.     Dim arr1(), arr2(), i&, j&, gd, jg()
    
13.     Set A_c = CreateObject("scripting.dictionary") '边_容量，例：c→f_c=3
    
14.     Set A_f = CreateObject("scripting.dictionary") '边_流量，例：c→f_f=0
    
15.     Set V_ljd = CreateObject("scripting.dictionary") '点_邻接点，例：a_ljd= b d c
    
16.     Set V_d = CreateObject("scripting.dictionary") '点集，例：a=1
    
17.     arr1 = Range("a19:a" & 18 + n).Value
    
18.     arr2 = Range("d18:e" & 18 + m).Value
    
19.     For i = 2 To m + 1
    
20.         A_c(arr2(i, 1) & "_c") = arr2(i, 2) '各边容量
    
21.         A_f(arr2(i, 1) & "_f") = 0 '各边初始流量为0
    
22.     Next i
    
23.     For i = 1 To n
    
24.         V_d(arr1(i, 1)) = i
    
25.         For j = 2 To m + 1
    
26.             If InStr(arr2(j, 1), "→") Then
    
27.                 gd = Split(arr2(j, 1), "→")
    
28.             Else
    
29.                 gd = Split(arr2(j, 1), "←")
    
30.             End If
    
31.             If arr1(i, 1) = gd(0) Then '比较左端点
    
32.                 V_ljd(arr1(i, 1) & "_ljd") = V_ljd(arr1(i, 1) & "_ljd") & " " & gd(1) '邻接点
    
33.             ElseIf arr1(i, 1) = gd(1) Then '比较右端点
    
34.                 V_ljd(arr1(i, 1) & "_ljd") = V_ljd(arr1(i, 1) & "_ljd") & " " & gd(0) '邻接点
    
35.             End If
    
36.         Next j
    
37.     Next i
    
38.     s = Range("d11").Value: t = Range("d12").Value
    
39.     If Not (V_d.exists(s)) Then MsgBox "起点不存在，请重新设置。": Range("d11").Select: Exit Sub
    
40.     If Not (V_d.exists(t)) Then MsgBox "终点不存在，请重新设置。": Range("d12").Select: Exit Sub
    
41.     '以上准备工作完成，下面进入计算部分
    
42.     Dim U As Object, V As Object, B As Object, DL As Object, B_name, B_name1$, B_name2$
    
43.     ReDim jg(1 To 1, 1 To m + 1)
    
44.     Sheet2.Cells.ClearContents
    
45.     Sheet2.Range("a1").Resize(2, m + 1) = WorksheetFunction.Transpose(arr2)
    
46.     Set U = CreateObject("scripting.dictionary") '标记点集U：点_序号
    
47.     Set V = CreateObject("scripting.dictionary") '扫描点集V：序号_点
    
48.     Set B = CreateObject("scripting.dictionary") '边集B：序号_边
    
49.     Set DL = CreateObject("scripting.dictionary") '记录所有点列：bh变量中含t的
    
50.     Dim s_sum#, gd_ljd, gd_fx, k&, bh, js&, pd1%, c_min#
    
51.     Do
    
52.         c_min = WorksheetFunction.Max(A_c.items) + 1
    
53.         U(s) = 1: V(1) = s: B(1) = "": k = 1: i = 0
    
54.         Do '广度优先生成树（字典U保证标记U外新点，字典V保证扫描标号最小的点，遵循BFS）
    
55.             i = i + 1
    
56.             gd_ljd = Split(V_ljd(V(i) & "_ljd"), " ")
    
57.             For j = 1 To UBound(gd_ljd) '第一个为空格
    
58.                 If Not (U.exists(gd_ljd(j))) Then '只选择不在U中的点
    
59.                     If A_f.exists(V(i) & "→" & gd_ljd(j) & "_f") Then '流出1：例：a→b
    
60.                         If A_f(V(i) & "→" & gd_ljd(j) & "_f") < A_c(V(i) & "→" & gd_ljd(j) & "_c") Then '流出U，f(α)<c(α)
    
61.                             k = k + 1: B(k) = B(i) & " " & V(i) & "→" & gd_ljd(j)
    
62.                             U(gd_ljd(j)) = k: V(k) = gd_ljd(j)
    
63.                         End If
    
64.                     ElseIf A_f.exists(gd_ljd(j) & "←" & V(i) & "_f") Then '流出2：例：b←a
    
65.                         If A_f(gd_ljd(j) & "←" & V(i) & "_f") < A_c(gd_ljd(j) & "←" & V(i) & "_c") Then '流出U，f(α)<c(α)
    
66.                             k = k + 1: B(k) = B(i) & " " & V(i) & "→" & gd_ljd(j) '点列中统一成→表示正向弧
    
67.                             U(gd_ljd(j)) = k: V(k) = gd_ljd(j)
    
68.                         End If
    
69.                     ElseIf A_f.exists(V(i) & "←" & gd_ljd(j) & "_f") Then '流入1：例：a←b
    
70.                         If A_f(V(i) & "←" & gd_ljd(j) & "_f") > 0 Then '流入U，f(α)>0
    
71.                             k = k + 1: B(k) = B(i) & " " & V(i) & "←" & gd_ljd(j)
    
72.                             U(gd_ljd(j)) = k: V(k) = gd_ljd(j)
    
73.                         End If
    
74.                     ElseIf A_f.exists(gd_ljd(j) & "→" & V(i) & "_f") Then '流出2：例：b→a
    
75.                         If A_f(gd_ljd(j) & "→" & V(i) & "_f") > 0 Then '流入U，f(α)>0
    
76.                             k = k + 1: B(k) = B(i) & " " & V(i) & "←" & gd_ljd(j) '点列中统一成←表示反向弧
    
77.                             U(gd_ljd(j)) = k: V(k) = gd_ljd(j)
    
78.                         End If
    
79.                     End If
    
80.                 End If
    
81.             Next j
    
82.             If i = n Then Exit Do '扫描完所有点后退出do循环
    
83.         Loop
    
84.         bh = B.items: pd1 = 0
    
85.         For i = 0 To UBound(bh)
    
86.             If InStr(1, bh(i), t) Then pd1 = 1: B_name = Split(bh(i), " "): DL(js + 1) = Mid(bh(i), 2): Exit For '提取s-t点列
    
87.         Next i
    
88.         js = js + 1
    
89.         If pd1 Then '点列中有t
    
90.             For i = 1 To UBound(B_name) '计算点列最大可增流量△
    
91.                 For j = Len(B_name(i)) To 1 Step -1 '颠倒，例：将a→b变为b←a进行存在性检测
    
92.                     B_name1 = B_name1 & Mid(B_name(i), j, 1)
    
93.                 Next j
    
94.                 If InStr(1, B_name1, "→") Then B_name1 = Replace(B_name1, "→", "←") Else B_name1 = Replace(B_name1, "←", "→")
    
95.                 If A_f.exists(B_name(i) & "_f") Then B_name2 = B_name(i) Else B_name2 = B_name1
    
96.                 If InStr(1, B_name(i), "→") Then '正向弧比较剩余流量c-f
    
97.                     If A_c(B_name2 & "_c") - A_f(B_name2 & "_f") < c_min Then c_min = A_c(B_name2 & "_c") - A_f(B_name2 & "_f")
    
98.                 Else '反向弧比较当前流量f
    
99.                     If A_f(B_name2, "_f") < c_min Then c_min = A_f(B_name2, "_f")
    
100.                 End If
     
101.             Next i
     
102.             For i = 1 To UBound(B_name)
     
103.                 If InStr(1, B_name(i), "→") Then
     
104.                     A_f(B_name(i) & "_f") = A_f(B_name(i) & "_f") + c_min '正向弧该边的流量加△，即：f'(α)=f(α)+△
     
105.                 Else
     
106.                     A_f(B_name(i) & "_f") = A_f(B_name(i) & "_f") - c_min '反向弧该边的流量减△，即：f'(α)=f(α)-△
     
107.                 End If
     
108.             Next i
     
109.         End If
     
110.         jg(1, 1) = "f" & js & "(α)"
     
111.         For i = 2 To m + 1 '转存中间/最终结果
     
112.             jg(1, i) = A_f(arr2(i, 1) & "_f")
     
113.         Next i
     
114.         Sheet2.Cells(2 + js, 1).Resize(1, m + 1).Value = jg '输出中间/最终结果
     
115.         If pd1 = 0 Then Exit Do '点列中无t退出
     
116.         U.RemoveAll: V.RemoveAll: B.RemoveAll: Erase B_name '删除所有结点标记
     
117.     Loop
     
118.     gd_ljd = Split(V_ljd(s & "_ljd"), " ")
     
119.     For i = 1 To UBound(gd_ljd) '汇总计算网络最大流量
     
120.         If A_f.exists(s & "→" & gd_ljd(i) & "_f") Then s_sum = s_sum + A_f(s & "→" & gd_ljd(i) & "_f") Else s_sum = s_sum + A_f(gd_ljd(i) & "←" & s & "_f")
     
121.     Next i
     
122.     With Sheet2
     
123.         .Cells(4 + js, 1).Value = "最大流量": .Cells(4 + js, 2).Value = s_sum
     
124.         For i = 1 To js - 1
     
125.             .Cells(5 + js + i, 1).Value = DL(i)
     
126.         Next i
     
127.     End With
     
128.     MsgBox "共进行：" & js & "次遍历检查，共找到：" & js - 1 & "条" & s & "-" & t & "点列。" & Chr(10) & Chr(10) & "网络最大流量：" & s_sum & "。" & Chr(10) & Chr(10) & "详细流量分配方案见工作表：" & Sheet2.Name
     
129. End Sub
     
130. Sub luanxu() '随机乱序边的排列
     
131.     Sheet1.Activate
     
132.     Application.EnableEvents = False
     
133.     Dim i&, j&, r&, gd, arr
     
134.     m = Range("b2").Value
     
135.     arr = Range("d19:h" & 18 + m).Value
     
136.     Randomize
     
137.     For i = 1 To m
     
138.         r = Int(Rnd() * (m - i + 1)) + i
     
139.         For j = 1 To UBound(arr, 2)
     
140.             gd = arr(i, j): arr(i, j) = arr(r, j): arr(r, j) = gd
     
141.         Next j
     
142.     Next i
     
143.     Range("d19").Resize(m, UBound(arr, 2)).Value = arr
     
144.     Application.EnableEvents = True
     
145. End Sub

复制代码

　　完毕。看一下行数。再呵呵……

aoe1981

　　帖中直观内容：
　　

　　核心说明：
　　1.网络N=(V,A,s,t,c(α))，其中：α∈A。相关变量为点集、边集、起点、终点、容量。
　　2.随机乱序边的排列旨在生成不同的邻接表，从而产生不同的广度优先生成树，以检测对网络最大流量计算及分配是否产生影响。
　　3.该实现算法可以处理无理数容量c(α)，如：2^0.5。
　　4.该算法不针对多源（起点）多汇（终点）网络。
　　5.独立运行⑤⑥步时，不针对手动喂入数据的完备性、正确性进行防错处理（指绿色字体字段下的数据）；如遇程序出错，请自行检查原始数据；复制粘贴数据时，请使用“选择性粘贴-数值”。
　　6.要求右侧直观图不仅同构而且形似的，点坐标亦需手动调整。

　　其他说明：
　　7.所以加入随机数据，是为了测试的方便，附件支持输入实际数据；但是个别数据要注意修改时机的把握，添加前最好先行备份，比如：点坐标的输入必须是在第③步生成点坐标产生随机坐标后再行修改，提前修改会被删除且添加不成功；这就要求仔细把握附件中步骤间的逻辑关系，比如：计算模块代码具有独立性，可不必依赖于成图模块代码，但依赖时，只是为了确保产生数据的正确性和完备性……

　　呵呵……

aoe1981

感觉在计算汇总最大网络流量时有点bug，可能是检测数据太少，没有暴露这个问题，明天再排查一下。
仔细检查了一下，汇总网络最大流量我是在起点s处，因此只需考虑两种情况：s→a、b←s，这两种情况都已涵盖。如果在终点t处汇总，则应考虑：a→t、t←b。这二者是等效的。上述代码是正确的。

但有意外的收获，查出了以下错误：
上楼“计算”模块100行代码下应当加入一句：

1.                 B_name1 = ""

复制代码

否则，上一个循环的结果会保留到下一个循环，从而造成错误，连肉眼都能看到的“点列流”都计算不到。1楼附件已同步更新。

aoe1981

　　错误示例：
　　

　　发现本错误的一组随机数据：

点V	X_dian	Y_dian	边A	容量c(α)
a	-6.36396	6.363961031	e←g	7
b	-8.94341	-1.007680285	b←g	1
c	-4.78829	-7.620517793	e→f	11
d	2.972512	-8.494949973	d←e	19
e	8.49495	-2.972511558	c→g	10
f	7.620518	4.788288689	d→g	20
g	1.00768	8.943409889	d→f	6
			a←b	12
			c←f	4
			b←d	1
			a←g	11
			b→e	17
			a→f	11

　　起点为e，终点为c。

qing0408

支持一下。不明觉厉

aoe1981

　　关于两点连线上插入点的坐标计算，我是取中点，比较简便。

　　a(x1,y1)，b(x2,y2)，插入点坐标为：((x1+x2)/2,(y1+y2)/2)

　　也可以插入在1/3处：

　　a(x1,y1)，b(x2,y2)，插入点坐标为：(x1＊2／3+x2/3,y1＊2／3+y2/3)

　　但是，随着数据的不同，箭头标记、边的容量标签总是会出现重叠，修改的意义不大。此处所说明的是直观图中的箭头、边容量的显示问题。


　　改在1/3处后，书本上的图变得好了：

　　

　　附件如下（其余与1楼同，只此一点不同）：
　　 网络最大流算法之VBA实现（标记点在三分之一处）.zip (67.21 KB, 下载次数: 42)

2018-1-4 20:35 上传

点击文件名下载附件

　　（找到s-t点列后按算法应当提前退出遍历，已添加，已更新）

aoe1981

　　这个图标记点也重复了：
　　

　　是因为规律撞见了规律的圆周坐标。

　　改为随机坐标，反复了几次，如下：
　　

　　这两个图算是所谓“同构异形”吧。

Nick_Chen0622

楼主，这个是图论的章节吗？我下载的附件运行不了，，，伤心