物元可拓法Excel计算程序

物元可拓法于80年代由我国蔡文教授创立，目前已广泛应用于新产品构思与设计、优化决策、控制、识别与评价等各个领域，无论在理论还是在实践上都发挥了越来越重要的作用。

物元是描述事物的名称、特征及量值3个基本元素的简称，在形式上可记为M=(N，c，v)=(N，c，c(N))。其中M、N、c、v分别是Matter、Name， Character， Value的缩写。可拓集合是用关联度将模糊集合的[0，1]闭合区间连续取值拓广到(-∞，+∞)实数轴，以表达物元的量值为实轴上的一点时符合要求的程度。物元分析是研究物元及其变化并用以解决矛盾问题的规律和方法，可拓学是用形式化的工具，从定性和定量两个角度去研究解决矛盾问题的规律和方法。物元可拓法结合二者，是将辨证逻辑和形式逻辑相结合的可拓逻辑，丰富了事物的内涵，客观地反映了物质世界的真实状态。

本次选用评价因子污染贡献率方法来确定权系数。主要计算程序：

Dim sRow As Integer, sCol As Integer    '起始的行与列
Dim i As Integer, j As Integer          '循环变量
Dim Xj As Double                        '定义实测值
Dim Aij As Double, Bij As Double        '定义标准域区间
Dim Apj As Double, Bpj As Double        '定义节域变量
Dim YZS As Integer                      '定义评价因子个数
Dim DJS As Integer                      '定义评价等级数
'得到起始行列值
sRow = InputBox("请输入监测数据第一个数的行号！", "输入行号", 0)
sCol = InputBox("请输入监测数据第一个数的列号！", "输入列号", 0)
YZS = InputBox("请输入评价因子个数!", "输入因子个数", 0)
DJS = InputBox("请输入评价等级个数!", "输入评价等级数", 0)
'插入标记列文字
With Sheets("sheet1")
  For i = 1 To DJS
      Cells(sRow + DJS + 2 + i, sCol - 1).Value = "关联函数k_等级" & i
  Next i
  Cells(sRow + 2 * DJS + 3, sCol - 1).Value = "X/S"
  Cells(sRow + 2 * DJS + 4, sCol - 1).Value = "归一化权重"
  For i = 1 To DJS
      Cells(sRow + 2 * DJS + 4 + i, sCol - 1).Value = "关联度K_等级" & i
  Next i
  Cells(sRow + 3 * DJS + 5, sCol - 1).Value = "可拓指数"
  
  '按列循环计算
  For j = sCol To sCol + YZS - 1
    '赋初值
    Xj = Cells(sRow, j).Value            '实测值
    Apj = Cells(sRow + 1, j).Value       '可拓域最小值
    Bpj = Cells(sRow + DJS + 2, j).Value '可拓域最大值
    
    For i = 1 To DJS
      '对aij,bij赋值
      Aij = Cells(sRow + i, j).Value
      Bij = Cells(sRow + i + 1, j).Value
      
      '按条件选择公式计算关联度
      If Xj > Aij And Xj < Bij Then 'xj<Xij 点x位于本标准之内
      
        If Xj <= ((Aij + Bij) / 2) Then
          Cells(sRow + i + DJS + 2, j).Value = -(Aij - Xj) / (Bij - Aij)
        Else
          Cells(sRow + i + DJS + 2, j).Value = -(Xj - Bij) / (Bij - Aij)
        End If
        
      Else          'xj<>Xij 点x位于本标准之外
      
        If Xj < Aij Then 'x位于标准的左边,此时有x<(ai+bi)/2
        
          If Xj <= (Apj + Bpj) / 2 Then
            Cells(sRow + i + DJS + 2, j).Value = (Aij - Xj) / (Apj - Aij)
          Else
            Cells(sRow + i + DJS + 2, j).Value = (Aij - Xj) / (2 * Xj - Bpj - Aij)
          End If
        
        ElseIf Xj > Bij Then 'x位于标准的右边,此时有x>(ai+bi)/2
        
          If Xj <= (Apj + Bpj) / 2 Then
            Cells(sRow + i + DJS + 2, j).Value = (Xj - Bij) / (Apj + Bij - 2 * Xj)
          Else
            Cells(sRow + i + DJS + 2, j).Value = (Xj - Bij) / (Bij - Bpj)
          End If
          
        End If
      End If
    Next i
  Next j
  

    '计算X/S
    For j = sCol To sCol + YZS - 1
        Dim a As Double
        a = 0
        For i = 1 To DJS + 2
            a = a + Cells(sRow + i, j)
        Next i
        Cells(sRow + 2 * DJS + 3, j).Value = Cells(sRow, j).Value * (DJS + 2) / a
    Next j
    '计算权重
    '计算x/s的总和
    a = 0
    For i = sCol To sCol + YZS - 1
        a = a + Cells(sRow + 2 * DJS + 3, i)
    Next i
    
    For j = sCol To sCol + YZS - 1
        Cells(sRow + 2 * DJS + 4, j).Value = Cells(sRow + 2 * DJS + 3, j).Value / a
    Next j
    
    '计算关联度
    Cells(sRow + 2 * DJS + 4, sCol + YZS) = "综合关联度"
    For i = 1 To DJS
        For j = sCol To sCol + YZS - 1
            Cells(sRow + 2 * DJS + 4 + i, j).Value = Cells(sRow + DJS + 2 + i, j).Value * Cells(sRow + 2 * DJS + 4, j).Value
        Next j
        Dim k As Integer
        a = 0
        For k = sCol To sCol + YZS - 1
           a = a + Cells(sRow + 2 * DJS + 4 + i, k) '综合关联度累加
        Next k
        Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value = a
    Next i
    '计算可拓指数
    '找最小与最大关联度
    Dim Kmax, Kmin As Double
    Kmax = Cells(sRow + 2 * DJS + 4 + 1, sCol + YZS).Value
    Kmin = Kmax
    For i = 2 To DJS
      If Kmax < Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value Then
        Kmax = Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value
      End If
      If Kmin > Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value Then
        Kmin = Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value
      End If
    Next i
    
    Dim KXP() As Double
    ReDim KXP(DJS) As Double
    For i = 1 To DJS
      KXP(i) = (Cells(sRow + 2 * DJS + 4 + i, sCol + YZS).Value - Kmin) / (Kmax - Kmin)
    Next i
    Dim FZ, FM As Double
    For i = 1 To DJS
      FZ = FZ + i * KXP(i)
      FM = FM + KXP(i)
    Next i
    Cells(sRow + 3 * DJS + 5, sCol).Value = FZ / FM
End With

实例文件