变权多因素模糊评判模型算法程序

       今天弄了个变权多因素模糊评判模型算法程序。也是帮同学完成论文上面的算法的。

		1	2	3	4
	A1	(80,95]	(90,100]	(85,90]	(85,95]
B1	A2	(15,25]	(20,30]	(10,20]	(15,20]
	A3	(85,100]	(80,90]	(80,90]	(90,100]
	A1	(85,90]	(85,100]	(85,95]	(90,95]
B2	A2	(50,60]	(60,65]	(55,70]	(50,60]
	A3	(70,90]	(80,90]	(55,95]	(80,85]
	A1	(30,45]	(35,40]	(30,40]	(40,45]
B3	A2	(65,70]	(60,70]	(70,75]	(65,75]
	A3	(85,95]	(90,100]	(80,95]	(85,95]
	A1	(45,50]	(50,55]	(50,60]	(45,60]
B4	A2	(70,75]	(70,80]	(75,80]	(70,80]
	A3	(80,90]	(75,85]	(75,80]	(80,90]

运行结果：

方案	A1	A2	A3	综合值	常权综合值
B1	0.684387	0.219464	0.096149	298.55008	276
B2	0.685332	0.218455	0.096214	598.88731	590.625
B3	0.685762	0.218167	0.09607	754.7995525	767.25
B4	0.685287	0.218548	0.096164	919.315045	936

这个问题好像是去解决物流中心选址等等。

下面给出VBA的代码：

'==================================
'作者：大漠．ｊｘｚｈｏｕｍｉｎ
'时间：２００８．６．２
'==================================
Option Base 1
Const ps = 4 '定义决策人常数
Const fs = 4 '定义方案的常数
Const ys = 3 '每种方案考虑因素的常数
Const sp = 5 '步长增加
Public AA(2 * ps) As Double
Public XX(fs, ys) As Double
Public max_num, min_num As Double
Public max_wj, min_wj As Double
Public wj(ys) As Double  '基础权重
Public w0(ys) As Double
Public r0(ys) As Double
Public r_x(ys) As Double
Public rx(ys) As Double
Public kk(ys) As Double
Sub main()
wj(1) = 0.55  '赋基础权向量值
wj(2) = 0.3
wj(3) = 0.15
max_wj = 0.55
min_wj = 0.15
Dim bqzs(ys) As Double, mid_num As Double, d As Double, d2 As Double
Call getX
Call getW0
Call getR
Call getK
With Worksheets("sheet2")
     For i = 1 To fs   '方案
         For j = 1 To ys  '因素
             mid_num = getBQZ(i, j)
             .Cells(i + 1, j + 1).Value = mid_num
             bqzs(j) = mid_num
         Next j
         For j = 1 To ys
             d = d + bqzs(j) * XX(i, j)  '综合值
             d2 = d2 + wj(j) * XX(i, j)  '常权综合值
         Next j
         .Cells(i + 1, 5).Value = d
         .Cells(i + 1, 6).Value = d2
     Next i
End With
End Sub
Sub getX()
Dim left_num, right_num As Double, mid_num As Double
Dim sum_num As Integer
For i = 1 To fs '方案
       For j = 1 To ys  '因素
            Call find_num(i, j) '获取某行的数组和该行最小值,最大值
            mid_num = 0
            For n = min_num To max_num - sp Step sp
                left_num = n
                right_num = left_num + sp
                sum_num = 0
                For m = 1 To 2 * ps Step 2
                   If AA(m) <= left_num And AA(m + 1) >= right_num Then
                        sum_num = sum_num + 1   '在区间范围则加1
                   End If
                Next m
                Dim u As Double
                u = Int(sum_num / ps * 1000000 + 0.5) / 1000000 '四舍五入，六位小数点
                If u <> 0 Then
                   mid_num = mid_num + Int(jifen(left_num, right_num, u, True) / jifen(left_num, right_num, u, False) * 1000000 + 0.5) / 1000000 '四舍五入，六位小数
                End If
            Next n
            XX(i, j) = mid_num
       Next j
Next i
End Sub
Sub find_num(ByVal i As Integer, ByVal j As Integer) '获取某行的数组和该行最小值,最大值
Dim t As Integer
Dim col_str As String
min_num = 1000000
max_num = 0
t = 0
With Worksheets("sheet1")
m = (i - 1) * 3 + j + 1 '行值
     For n = 3 To ps + 2
         t = t + 1
         col_str = Trim(.Cells(m, n).Value)
         AA(t) = Val(Mid(col_str, 2, (InStr(1, col_str, ",") - 2)))
         t = t + 1
         AA(t) = Val(Mid(col_str, (InStr(1, col_str, ",") + 1), (InStr(1, col_str, "]") - (InStr(1, col_str, ",")) - 1)))
     Next n
End With
For m = 1 To 2 * ps
    If AA(m) < min_num Then
        min_num = AA(m)    '得到最小值
    End If
Next m
For m = 1 To 2 * ps
    If AA(m) > max_num Then
        max_num = AA(m)    '得到最大值
    End If
Next m
End Sub
Sub getW0()
For i = 1 To ys
     w0(i) = Int(wj(i) / (max_wj + min_wj) * 1000000 + 0.5) / 1000000 '四舍五入，六位小数，得到w0数组
Next i
End Sub
Sub getR()
Dim mid_num As Double
For i = 1 To ys
    mid_num = 0
    For j = 1 To ys
        If i <> j Then
            mid_num = mid_num + wj(j)
        End If
    Next j
    r0(i) = Int(w0(i) * mid_num / (1 - w0(i)) * 1000000 + 0.5) / 1000000  '四舍五入，六位小数，得到r0数组
    rx(i) = mid_num  '得到rx数组
Next i
For i = 1 To ys
    mid_num = 0
    For j = 1 To ys
         If i <> j Then
            mid_num = mid_num + r0(j)
         End If
    Next j
    r_x(i) = mid_num '得到r_x数组
Next i
End Sub
Sub getK()
For i = 1 To ys
     kk(i) = 1 - (Int(1 / (r_x(i) * (Log(wj(i) / r0(i)))) * 1000000 + 0.5) / 1000000)
Next i
End Sub
Function getBQZ(ByVal i As Integer, ByVal j As Integer) As Double
Dim x As Double
Dim feizi, feimu As Double
x = XX(i, j) '获取某个方案的某个因素的x值
fenzi = r0(j) * Exp(((-1) * x ^ (1 - kk(j))) / ((1 - kk(j)) * r_x(j)))
For m = 1 To ys
    x = XX(i, m)
    fenmu = fenmu + r0(m) * Exp(((-1) * x ^ (1 - kk(m))) / ((1 - kk(m)) * r_x(m)))
Next m
getBQZ = Int(fenzi / fenmu * 1000000 + 0.5) / 1000000
End Function
Public Function jifen(ByVal a As Double, ByVal b As Double, u As Double, bl As Boolean) As Double
Dim n As Integer
Dim h As Double, T1n As Double, T2n As Double, I1n  As Double, I2n As Double
n = 1                          '初值
Const eps = 0.00000001         '积分精度
h = b - a
T2n = h * (f(a, u, bl) + f(b, u, bl)) / 2 '梯形公式计算面积近似值
I2n = h * (f(a, u, bl) + f(b, u, bl)) / 2
I1n = 0
Do While Abs(I2n - I1n) >= eps  '求积分，当上次积分值I1n与本次积分值I2n之差小于esp时，
                                '则认为所求积分的近似度已达到要求
     T1n = T2n
     I1n = I2n
     Dim sigma As Double
     sigma = 0
     Dim k As Integer
     For k = 0 To n - 1          '求变步长梯形的和部分
         Dim x As Double
         x = a + (k + 0.5) * h
         sigma = sigma + f(x, u, bl)
     Next k
     T2n = (T1n + h * sigma) / 2  '变步长梯形
     I2n = (4 * T2n - T1n) / 3    '辛普森公式
     n = n * 2                    '划分
     h = h / 2
Loop
jifen = I2n                       '最后结果
'MsgBox jifen
End Function
Function f(x As Double, u As Double, bl As Boolean) As Double
If bl = True Then
    f = u * x  '分子积分
Else: f = u    '分母积分
End If
End Function
Function test()
End Function