[ 熵权法 ]

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

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

公式如下：

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

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

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

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

具体代码如下

Sub 熵权法()Dim rg As Range, nrow As Integer, ncol As IntegerDim r As Integer, c As Integer'************************变量初始化*******************************Set rg = Selection  '选区With rgnrow = .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 - 1Max = 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 - 1If Cells(r + 1, c + k) = 1 ThenCells(lr + i, c + k) = (Cells(r + i, c + k) - Min) / (Max - Min)ElseIf Cells(r + 1, c + k) = -1 ThenCells(lr + i, c + k) = (Max - Cells(r + i, c + k)) / (Max - Min)ElseMsgBox ("请输入正确的指标标签,-1或1，1表示指标为正向指标；-1表示指标为负向指标")Exit ForEnd IfNextNextCells(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 - 2Sum = Application.WorksheetFunction.Sum(Range(Cells(r, c + k), Cells(lr, c + k)))For i = 0 To nrow - 3Cells(lr + 2 + i, c + k) = Cells(r + i, c + k) / SumNextNextCells(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 - 2For i = 0 To nrow - 3n = Application.Ln(Cells(r + i, c + k))b = Application.WorksheetFunction.IfError(n, 0)Cells(lr + 2 + i, c + k) = Cells(r + i, c + k) * bNextNextr = lr + 2   'ylny矩阵第一个个单元格行号lr = lr + nrow - 1  'ylny矩阵最后一个单元格行号For k = 0 To ncol - 2Cells(lr + 2, c + k) = Application.WorksheetFunction.Sum(Range(Cells(r, c + k), Cells(lr, c + k))) * mNextCells(lr + 2, c - 1) = "信息熵："'*******************************************************************************'**********  Step 4 . 计算信息冗余度  *******************************************r = lr + 2 '信息熵矩阵第一个单元格行号For k = 0 To ncol - 2Cells(r + 2, c + k) = 1 - Cells(r, c + k)NextCells(r + 2, c - 1) = "信息冗余度："'************************************************************************************'***********  Step 5 . 计算指标权重  **************************************************r = r + 2Sum = Application.WorksheetFunction.Sum(Range(Cells(r, c), Cells(r, c + ncol - 2)))For k = 0 To ncol - 2Cells(r + 2, c + k) = Cells(r, c + k) / SumWith Cells(r + 2, c + k).Font.ColorIndex = 3.Font.Bold = TrueEnd WithNextCells(r + 2, c - 1) = "指标权重："With Cells(r + 2, c - 1).Font.ColorIndex = 3.Font.Bold = TrueEnd With'***************************************************************************************End Sub

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