熵值法运行程序

熵值法运行程序 精品文档 --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------------------ Option Base 1 Dim zbdf0(), zbdfl(), min_zb(), max_zb(), zbh(), p0(), pl(), pclogp(), h(), w(), sum_h As Single Dim temp, fw, df As Variant Dim SZfCommandBar As CommandBar Dim SZfCommandBarButton As CommandBarButton Public n, m Private Sub Workbook_BeforeClose(CanceI As Boolean) Application.CommandBars("熵值法").Delete End Sub Private Sub Workbook_open() On Error Resume Next Application.CommandBars("熵值法").Delete Set SZfCommandBar = Application.CommandBars.Add("熵值法") With SZfCommandBar.Controls Set SZfCommandBarButton = .Add(msoControlButton) With szfCommand.BarButton .Style = msoButtonlconAndCaption .Caption = "熵值法" .OnAction = "S2F" End With --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------------------ 精品文档 --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------ ------------ End With SZfCommandBar.ViSmle = True End Sub Private Sub S2F() On Error Resume Next fw = InputBox("请输入数据在EXCEL中的起始结束位置" & vbCrLf & vbCrLf & " ※一定要正确输入，否则按确定后将会出错! ", "输入范围", ActiveWindow.RangeSelection.AddressLocal(0, 0)) If Len(Trim(fw)) = 0 Then MsgBox "没有输入正确范围，请重新执行程序输入正确的数据范围!", vbOKOnly, "没 有输入" Else n = Range(fw).Rows.Count m = Range(fw).Coluruns.Count ReDim zbdf0(n, m), zbdfl(n, m), min_zb(m), max_zb(m), zbh(m), pO(n, m), pl(n, m), pclogp(n, m), h(m), w(m) For i = l To n For J = 1 To m zbdf0(i, J) = ActiveSheet.Range(fw).Cells(i, J) Next Next For J = 1 To m min_zb(J) = zbdfO(1, J) max_zb(J) = zbdfO(1, J) --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------ ------------ 精品文档 --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------ ------------ zbh(J) = 0 For i = l To n If min_zb(J) > zbdfO(i, J) Then min_zb(J) = zbdf0(i, J) End If If max_zb(J) < zbdf0(i, J) Then max_zb(J) = zbdf0(i, J) End If zbh(J) = zbh(J) + zbdf0(i, J) Next Next For J = 1 To m zbh(J) = 0 For i = 1 To n zbdfl(i, J) = IIf((min_zb(J)) >= 0, zbdf0(i, J), (zbdm(i, J) - mm_zb(J)) / (max_zb(J) - mim_zb(J))) zbh(J) = zbh(J) + zbdfl(i, J) Next Next sum_h = 0 For J = 1 To m h(J) = 0 --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------ ------------ 精品文档 --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------ ------------ For i = l To n p0(i, J) = zbdfl(i, J) / zbh(J) pl(i, J) = 10000 * pO(i, J) + 1 pclogp(i, J) = pl(i, J) * ApplicaonWorksheetFunction.Logl0(pl(i, J)) h(J) = h(J) + pelogp(i, J) Next sum_h = sum_h + h(J) Next For J = 1 To m w(J) = h(J) / sum_h Next df = Applicatin.WorksheetFunction.MMun(pclogp, Application.WorksheetFunction.Transpose(w)) Application.Worksheets("熵值法输出").Delete Worksheets.Add after:=Sheets(Application.Worksheets.Count) Appliction.ActiveSheet.Name = "熵值法输出" Columns("B:B").ColumnWidth = 15 [B1] = "熵值法得分" For i = 2 To n + 1 Cells(i, 2).Value = df(i - 1, 1) Next [C1] = "熵值法排名" --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------ ------------ 精品文档 --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------------------ Range("C2:C" & (n + l)).FormulaArray = "=RANK(RC[-1 ]:R[" & (n - 1) & "l]C[-1 ],R2C2:R" & n + l & "C21)" End If End Sub --------------------------精品文档，可以编辑修改，等待你的下载，管理，教育文档---------------------- ------------------------------------------------------------------------------------------------------------------------------------------------------