熵权法计算评价指标权重——使用Excel VBA实现

[ 熵权法 ]

信息是系统有序程度的一个度量，熵是系统无序程度的一个度量；根据信息熵的定义，对于某项指标，可以用熵值来判断某个指标的离散程度，其信息熵值越小，指标的离散程度越大， 该指标对综合评价的影响（即权重）就越大，如果某项指标的值全部相等，则该指标在综合评价中不起作用。因此，可利用信息熵这个工具，计算出各个指标的权重，为多指标综合评价提供依据。

在进行熵权法之前，如果数据方向不一致时，需要进行提前数据处理，通常为正向化或者逆向化两种处理（统称为数据归一化处理）。

公式如下：

我们常常通常需要使用一些统计软件以及脚本语言来计算，如：Spss，Matlab，stata，python等诸如此类的工具，但对于大部分不太习惯用统计软件或者其他编程语言的人来说使用并不方便。

为大家分享一段Excel内的VBA代码来实现在Excel中自动计算熵权权重，无需下载任何软件即可计算权重。

下面是我所使用的示范数据，大家可以从后台找我领取或者微信号公众号主页回复 “熵值法”即可获取代码以及练习数据哦。

Excel自动计算熵值法链接：https://pan.quark.cn/s/3fe506701b6c

具体代码如下

Sub 熵权法()

Dim rg As Range, nrow As Integer, ncol As Integer

Dim r As Integer, c As Integer



   '************************变量初始化*******************************

   Set rg = Selection  '选区

   With rg

   nrow = .Rows.Count   '选区总行数

   ncol = .Columns.Count '选区总列数

   r = .Row '选区第一个单元格行号

   c = .Column '选区第一个单元格列号

   lr = r + nrow - 1 '选区最后一个单元格行号

   lc = c + ncol - 1 '选区最后一个单元格列号

   End With



  '*******  Step 1 . 标准化处理  *****************************************************

   For k = 1 To ncol - 1



    Max = Application.WorksheetFunction.Max(Range(Cells(r + 2, c + k), Cells(lr, c + k)))

    Min = Application.WorksheetFunction.Min(Range(Cells(r + 2, c + k), Cells(lr, c + k)))



      For i = 2 To nrow - 1



         If Cells(r + 1, c + k) = 1 Then



          Cells(lr + i, c + k) = (Cells(r + i, c + k) - Min) / (Max - Min)

         ElseIf Cells(r + 1, c + k) = -1 Then

           Cells(lr + i, c + k) = (Max - Cells(r + i, c + k)) / (Max - Min)

         Else

           MsgBox ("请输入正确的指标标签,-1或1，1表示指标为正向指标；-1表示指标为负向指标")

           Exit For

        End If

      Next





   Next

   Cells(lr + 2, c) = "标准化"

 '********************************************************************



   '********  Step 2 .计算第i年份第j项指标值的比重 ********************************

        '1初始化变量的值

    r = lr + 2 '标准化矩阵的第一个单元格行号

    c = c + 1 '标准化矩阵的第一个单元格列号

    lr = lr + nrow - 1  '标准化矩阵的最后一个单元格行号

    lc = ncol - 1 '标准化矩阵的最后一个单元格列号



    For k = 0 To ncol - 2

     Sum = Application.WorksheetFunction.Sum(Range(Cells(r, c + k), Cells(lr, c + k)))

       For i = 0 To nrow - 3

       Cells(lr + 2 + i, c + k) = Cells(r + i, c + k) / Sum

       Next

    Next

      Cells(lr + 2, c - 1) = "第i年份第j项指标值的比重："

'************************************************************************



'**********  Step 3 . 计算指标信息熵  *******************************************

    r = lr + 2  '比重矩阵第一个单元格行号

    lr = lr + nrow - 1 '比重矩阵最后一个单元格行号

    m = -1 / Application.Ln(nrow - 2)

         For k = 0 To ncol - 2

             For i = 0 To nrow - 3

              n = Application.Ln(Cells(r + i, c + k))

              b = Application.WorksheetFunction.IfError(n, 0)

              Cells(lr + 2 + i, c + k) = Cells(r + i, c + k) * b



            Next

        Next

     r = lr + 2   'ylny矩阵第一个个单元格行号

     lr = lr + nrow - 1  'ylny矩阵最后一个单元格行号



  For k = 0 To ncol - 2

      Cells(lr + 2, c + k) = Application.WorksheetFunction.Sum(Range(Cells(r, c + k), Cells(lr, c + k))) * m



   Next

      Cells(lr + 2, c - 1) = "信息熵："

 '*******************************************************************************

 '**********  Step 4 . 计算信息冗余度  *******************************************

   r = lr + 2 '信息熵矩阵第一个单元格行号

   For k = 0 To ncol - 2

    Cells(r + 2, c + k) = 1 - Cells(r, c + k)

   Next

    Cells(r + 2, c - 1) = "信息冗余度："

'************************************************************************************

'***********  Step 5 . 计算指标权重  **************************************************

  r = r + 2

  Sum = Application.WorksheetFunction.Sum(Range(Cells(r, c), Cells(r, c + ncol - 2)))

  For k = 0 To ncol - 2

      Cells(r + 2, c + k) = Cells(r, c + k) / Sum

      With Cells(r + 2, c + k)

       .Font.ColorIndex = 3

       .Font.Bold = True

      End With

  Next

  Cells(r + 2, c - 1) = "指标权重："

  With Cells(r + 2, c - 1)

   .Font.ColorIndex = 3

   .Font.Bold = True

  End With

'***************************************************************************************

End Sub

需要资料的欢迎私信后台！