基于VB的耕地地力评价指标层次分析方法
Analytic hierarchy process of cultivated land productivity evaluation index based on VB
殷丽萍① 黄红梅② 邹忠①
Yinliping Huanghongmei Zouzhong
①如皋市农业技术推广中心②伊宁县农业技术推广中心
①Rugao Agricultural Technology Extension Center ②Yining County Agricultural Technology Extension Center
摘要：耕地地力评价技术系统复杂，其核心技术——评价指标层次分析过程繁复、数据量大。运用VB编程技术化繁为简，提高分析速度和精度，具有广泛的适用性和实用性。
Abstract: the technology system of cultivated land productivity evaluation is complex, and its core technology, analytic hierarchy process of evaluation index, is complex and has a large amount of data. Using VB programming technology to simplify the complex, improve the analysis speed and accuracy, has a wide range of applicability and practicality.
关键词：VB；地力评价；层次分析
Key words: VB; Evaluation of soil fertility; Analytic hierarchy process
耕地地力评价工作，主要包括评价指标筛选、权重和隶属度确定、指标层次分析、评价指数计算、地力分级等五个方面，系统而复杂，特别是指标层次分析，计算量繁复，技术要求高，通常成为制约耕地地力评价工作开展的瓶颈，从而导致许多地方都不得不将该工作交由第三方完成。众所周知，第三方通常属于商业化运作，其责任心、专业关联性都远不如农业部门，往往都是一个模板，通过套改数据而成，缺少其评价的针对性和系统性。因此，农业部门独立开展耕地地力评价工作，很有必要，也很重要。
耕地地力评价工作主要依据《耕地地力调查与质量评价技术规程》（NY/T 1634-2008）进行。因此，其基本原理和方法必须依照该规程开展，本文主要就耕地地力评价指标一致性评估方法方面重点展开。当然，为让大家系统掌握耕地地力评价的系统方法，本文将依据规程要求，将指标筛选、权重和隶属度确定、评价指数计算、地力分级等部分的操作方法和注意事项一并简述。
1 评价指标筛选
在2018年以前，评价指标的筛选基本上都是依照规程要求，通过技术初筛，再经专家打分评定而成。但在2019年农业农村部耕地质量监测保护中心发布了《全国耕地质量等级评价指标体系》的通知以后，其评价指标就从这个库中进行筛选。在全国耕地质量等级评价指标体系中，系统列出了各大农区的指标库，如甘新区的北疆农牧林区，就确定了灌溉能力、地形部位等16个指标。但具体到某个县市，则应根据其自身的具体情况而确定。其原则就是，在耕地质量管理系统中空间属性数据库和理化性状数据库中，对已经收集到的和即将可以收集到的数据，与指标体系进行比对，将具备数据的指标选出，列入本市县的评价指标。以伊宁县为例，其评价指标共筛选9个指标，详见下表。
伊宁县耕地地力评价指标筛选结果表
首先需要注意的是，依照规程中附录C中层次分析法，其层次分类中，需要将选中的指标进行归类，为便于计算机自动化处理，需添加状态层（B层）归类代码属性（BNo列值）B层名称值（BName列值）。其次是筛选后的指标有可能会出现某个层次中只有1个指标（如剖面性状中的质地构型和立地条件中的地形部位），这就需要进行规并处理，将其与特性相近的指标规并为一类进行评估（如伊宁县就将这两指标规并为立地条件），详见上表中BNo列和BName列中编码，在BNo中将规并后的使用同一编码，并使用规并后的B层名称行在BName列中将其赋值为1，以便在VB编程处理时识别使用。
2 权重和隶属度
虽然农业农村部耕地质量监测保护中心发布的《全国耕地质量等级评价指标体系》中已经为全部的指标都已经赋予了相应的权重，但具体到各市县，在完成指标筛选后，仍需对权重作相应的调整。以伊宁县为例，原16个指标权重之和为0.9998（实际应该为1，表中已经进行了修正），而选中的9个指标（将筛选值赋值为1）之和只有0.6760，因此需要将各指标的权重作相应调整，将其原权重分别乘以1/0.6760，即可将总权重修正回1。其Visual Basic代码如下：
Dim iL As Integer,指标个数 As Integer
Dim dL As Double, sumOldE As Double
Dim sumOldAll As Double, sumNew As Double, 换算系数 As Double
指标个数 = 16
For iL = 1 To 指标个数
sumOldAll = sumOldAll + 权重(iL)
If 筛选值 = 1 Then
sumOldE = sumold + 原权重(iL)
End If
Next
换算系数 = sumOldAll / sumOldE
For iL = 1 To 指标个数
If 筛选值 = 1 Then
现权重(iL) = 权重(iL) * 换算系数
原权重(iL) = 权重(iL)
Else
现权重(iL) = 0
原权重(iL) = 0
End If
Next
其文本属性指标的隶属度，在指标体系中已经进行了相应的设定，只需直接调用即可。
需要特别注意的是，在数值型指标隶属函数模型中，对各指标名称模型中的系数a、标准指标值c、值上下限u都已经作了明确的赋值。但在严格执行指标体系技术路线的同时，一定要认真审视体系中的各个值的合理性。以北疆农牧林区指标体系为例，其a值和c值计12个数值中，就有6个数值不合理，需要进行调整后才能使用。如a值中土壤容重表中为6.390020，应该调整为0.390020，应为输入有误导致；c值中，有机质、有效磷、速效钾、有效土层厚度和地下水埋深数值均大于u的上限值，应该调整为u的上限值使用，这是由于数据合理性审核失误所致（详见下表）。
390.390029北疆农牧林区数值型指标隶属函数表
3 指标层次分析
指标层次分析主要是对评价指标一致性进行评估。基本原理是根据指标性质和分析目标，将指标分解为不同的组成因子，按照因子间的相互关联影响以及隶属关系，将因子按不同层次聚合，形成一个多层次的分析结构模型，并最终把系统分析归结为最低层〈指标层）相对于最高层（目标层）的相对重要性权值的确定。
3.1 设计框架
VB软件设计上，首先创建一个VB工程，通过引用Excel对象库，然后根据层次分析思路，在对评价指标分级排序后，分别对A层、Bi层和指标层创建比较矩阵，并根据规范流程，依次推导出B矩阵、矩阵、W矩阵、λ矩阵和CR值。其设计架构如下图。
3.2创建工程
通过Visual Basic6.0创建新的标准EXE工程，并添加对Microsoft Excel Objects Library的引用（以便执行对Excel数据表的调用）。
3.2.1打开文件
为读取基础数据，可在窗体上添加1个“打开Excel…”的命令按钮，用于打开Excel文件，将被评估的指标体系数据区选中。其代码如下：
Dim iL As Integer, jL As Integer, kl As Integer, mL As Integer, nL As Integer, oL As Integer
Dim sL As String, sL2 As String, sL3 As String
Dim sslb() As String, sslb2() As String, sslb3() As String
Dim BiL() As Integer
Dim tsL As String
Dim tRangeL As Excel.Range
If Not xlAppf2 Is Nothing Then
xlAppf2.DisplayAlerts = False '不提示询问是否保存
工作薄2.Save
工作薄2.Close
xlAppf2.Quit
Set 工作薄2 = Nothing
Set xlAppf2 = Nothing
List2.Clear
End If
CommonDialog1.Filter = "电子表格|*.xls;*.xlsx;*.xlsm"
CommonDialog1.FilterIndex = 1
CommonDialog1.CancelError = False
CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then Exit Sub
Set xlAppf2 = CreateObject("Excel.Application") '创建EXCEL对象
Set 工作薄2 = xlAppf2.Workbooks.Open(CommonDialog1.FileName)
xlAppf2.Visible = True
3.2.2读取数据
在窗体上添加1个“读取数据”按钮，用于执行将指标体系读取到相应的数组中，以便用于进行一致性评估。同时将指标体系制作出“耕地地力评价规则总表”和“评价因素组合权重计算结果表”。其代码如下：
CellRow = xlAppf2.Selection.Row
CellRows = xlAppf2.Selection.Rows.Count
CellCol = xlAppf2.Selection.Column
CellCols = xlAppf2.Selection.Columns.Count
If xlAppf2 Is Nothing Then MsgBox "请先打开数据源！": Exit Sub
If xlAppf2.Visible = False Then
xlAppf2.Visible = True
Exit Sub
Else
'单元格画表格线
CellRow = xlAppf2.Selection.Row
CellRows = xlAppf2.Selection.Rows.Count
CellCol = xlAppf2.Selection.Column
CellCols = xlAppf2.Selection.Columns.Count
指定范围全画表格线 CellRow, CellCol, CellRows - 1, CellCols - 1
For iL = CellRow To CellRow + CellRows - 1
sL = ""
For jL = CellCol To CellCol + CellCols - 1
If sL = "" Then
sL = xlAppf2.ActiveSheet.Cells(iL, jL)
Else
sL = sL & "," & xlAppf2.ActiveSheet.Cells(iL, jL)
End If
Next
List2.AddItem sL
Next
End If
If List2.ListCount > 0 Then
sL = ""
ReDim FHDataf(List2.ListCount - 1, CellCols - 1)
For iL = 0 To List2.ListCount - 1
sslb = Split(List2.List(iL), ",")
For jL = 0 To UBound(sslb)
FHDataf(iL, jL) = sslb(jL)
Next
If Val(FHDataf(iL, 6)) > 0 And Val(FHDataf(iL, 7)) = 1 Then
If sL = "" Then
sL = FHDataf(iL, 1) & Chr(9) & FHDataf(iL, 6) 'sL为B层和B层代码，并由此生成规则表
Else
sL = sL & "," & FHDataf(iL, 1) & Chr(9) & FHDataf(iL, 6)
End If
End If
Next
'Exit Sub
'MsgBox sL
'开始制作规则总表
sslb = Split(sL, ",")
sL3 = ""
For iL = 0 To UBound(sslb)
sslb2 = Split(sslb(iL), Chr(9))
sL2 = sslb2(1) '取B层代码
For jL = 1 To List2.ListCount - 1
If FHDataf(jL, 6) = sL2 Then
If sL3 = "" Then
sL3 = FHDataf(jL, 0) & Chr(9) & sslb2(0) & Chr(9) & FHDataf(jL, 2) & Chr(9) & FHDataf(jL, 8) & ","
Else '少了最后的逗号和分号会少个条记录
sL3 = sL3 & FHDataf(jL, 0) & Chr(9) & sslb2(0) & Chr(9) & FHDataf(jL, 2) & Chr(9) & FHDataf(jL, 8) & ","
End If
End If
Next
sL3 = sL3 & ";"
Next
lL = 0
UseRows = xlAppf2.ActiveSheet.UsedRange.Rows.Count
xlAppf2.ActiveSheet.Cells(UseRows + 1, 2) = "耕地地力评价规则总表"
tsL = xlAppf2.ActiveSheet.Cells(UseRows + 1, 2).Address
tsL = tsL & ":" & xlAppf2.ActiveSheet.Cells(UseRows + 1, 5).Address
Set tRangeL = xlAppf2.ActiveSheet.Range(tsL)
tRangeL.Merge
单元格上下左右居中 tRangeL
xlAppf2.ActiveSheet.Cells(UseRows + 2, 2) = "目标层（A）"
F基准行号 = UseRows + 2
xlAppf2.ActiveSheet.Cells(UseRows + 2, 3) = "状态层（B）"
xlAppf2.ActiveSheet.Cells(UseRows + 2, 4) = "指标层（C）"
xlAppf2.ActiveSheet.Cells(UseRows + 2, 5) = "权重"
sslb = Split(sL3, ";") '取B数组
ReDim BiL(UBound(sslb)) As Integer
BiL(0) = UBound(sslb) '检查sslb的来源与组成
For iL = 1 To BiL(0) '初始化BiL(i)
BiL(iL) = 0
Next
lL = BiL(0)
'在此加上对B层的预留
iL = UseRows + 3 '3应该换成BiL(0)
kl = UseRows + 2 + UBound(sslb) '标识当前已经使用最大行号
For mL = 0 To UBound(sslb) - 1
dL = 0
sslb2 = Split(sslb(mL), ",") '取C数组
BiL(mL + 1) = UBound(sslb2)
lL = lL + UBound(sslb2)
For nL = 0 To UBound(sslb2) - 1
kl = kl + 1
sslb3 = Split(sslb2(nL), Chr(9)) '取各字段值，如耕地地力、立地条件、坡度、坡度权重
If mL = 0 And nL = 0 Then
xlAppf2.ActiveSheet.Cells(kl, 2) = sslb3(0)
xlAppf2.ActiveSheet.Cells(iL, 3) = sslb3(0)
End If
'在此加上合并第一列
If nL = 0 Then
xlAppf2.ActiveSheet.Cells(kl, 3) = sslb3(1)
xlAppf2.ActiveSheet.Cells(iL + mL, 4) = sslb3(1)
End If
'在此加上合并第二列
xlAppf2.ActiveSheet.Cells(kl, 4) = sslb3(2)
xlAppf2.ActiveSheet.Cells(kl, 5) = Int(Val(sslb3(3)) * 100000 + 0.5) / 100000
dL = dL + Int(Val(sslb3(3)) * 100000 + 0.5) / 100000
'在此加上设置居中、全表格线
Next
'加上B层权重小计
xlAppf2.ActiveSheet.Cells(iL + mL, 5) = dL
Next
End If
kl = xlAppf2.ActiveSheet.UsedRange.Rows.Count + 1
tsL = xlAppf2.ActiveSheet.Cells(UseRows + 3, 2).Address
tsL = tsL & ":" & xlAppf2.ActiveSheet.Cells(kl - 1, 2).Address
Set tRangeL = xlAppf2.ActiveSheet.Range(tsL)
tRangeL.Merge
单元格上下左右居中 tRangeL
tsL = xlAppf2.ActiveSheet.Cells(UseRows + 2, 2).Address
tsL = tsL & ":" & xlAppf2.ActiveSheet.Cells(kl - 1, 4).Address
Set tRangeL = xlAppf2.ActiveSheet.Range(tsL)
单元格上下左右居中 tRangeL
tsL = xlAppf2.ActiveSheet.Cells(UseRows + 2, 2).Address
tsL = tsL & ":" & xlAppf2.ActiveSheet.Cells(kl - 1, 5).Address
Set tRangeL = xlAppf2.ActiveSheet.Range(tsL)
单元格画表格线 tRangeL '单元格区域全画表格线
tsL = xlAppf2.ActiveSheet.Cells(UseRows + 2, 2).Address
tsL = tsL & ":" & xlAppf2.ActiveSheet.Cells(UseRows + 2, 5).Address
Set tRangeL = xlAppf2.ActiveSheet.Range(tsL)
单元格上下左右居中 tRangeL
oL = 0
For nL = 0 To UBound(BiL)
F准则层数 = BiL(0)
tsL = xlAppf2.ActiveSheet.Cells(UseRows + 3 + oL, 3).Address
oL = oL + BiL(nL)
tsL = tsL & ":" & xlAppf2.ActiveSheet.Cells(UseRows + 2 + oL, 3).Address
Set tRangeL = xlAppf2.ActiveSheet.Range(tsL)
tRangeL.Merge '合并单元格
单元格上下左右居中 tRangeL
Next
3.2.3指标评估
指标评估首先对所有状态层进行评估，然后对目标层进行评估，最后对由全部指标层组成的组合权重指标层进行评估，全部合格后方才说明全部分组及全部指标权重一致性符合评价要求。具体代码如下：
'生成比较矩阵检验计算过程表
oL = 0 '初始化累计用掉的数据行数
For nL = 0 To UBound(BiL)
kl = xlAppf2.ActiveSheet.UsedRange.Rows.Count + 1
xlAppf2.ActiveSheet.Cells(kl + 1, 2) = xlAppf2.ActiveSheet.Cells(iL + oL, 3) & "比较矩阵"
xlAppf2.ActiveSheet.Cells(kl + 2, 1) = "比较矩阵"
jL = BiL(nL)
ReDim 比较矩阵(jL, jL)
FMidStr = ""
For mL = 1 To jL
If mL = 1 Then FMidStr = xlAppf2.ActiveSheet.Cells(iL + oL, 3) & ":"
xlAppf2.ActiveSheet.Cells(kl + 1 + mL, 2) = xlAppf2.ActiveSheet.Cells(iL + oL + mL - 1, 4)
xlAppf2.ActiveSheet.Cells(kl + 1 + mL, 3) = Val(xlAppf2.ActiveSheet.Cells(iL + oL + mL - 1, 5)) / Val(xlAppf2.ActiveSheet.Cells(iL + oL, 5))
比较矩阵(mL - 1, 0) = Val(xlAppf2.ActiveSheet.Cells(kl + 1 + mL, 3))
FMidStr = FMidStr & xlAppf2.ActiveSheet.Cells(kl + 1 + mL, 2) & ","
Next
由一列数据生成比较矩阵 jL - 1, kl 'jL-1为BiL值减1，kL为用掉的行数加1
oL = oL + BiL(nL)
Next
F头表行数 = oL
kl = xlAppf2.ActiveSheet.UsedRange.Rows.Count + 1 '组合权重计算
xlAppf2.ActiveSheet.Cells(kl + 1, 2) = "组合层比较矩阵"
xlAppf2.ActiveSheet.Cells(kl + 2, 1) = "比较矩阵"
ReDim 比较矩阵(F头表行数, F头表行数)
FMidStr = ""
For mL = 1 To F头表行数
If mL = 1 Then FMidStr = xlAppf2.ActiveSheet.Cells(iL + oL, 3) & ":"
xlAppf2.ActiveSheet.Cells(kl + 1 + mL, 2) = xlAppf2.ActiveSheet.Cells(iL + mL - 1, 4)
xlAppf2.ActiveSheet.Cells(kl + 1 + mL, 3) = Val(xlAppf2.ActiveSheet.Cells(iL + mL - 1, 5)) / Val(xlAppf2.ActiveSheet.Cells(iL, 5))
比较矩阵(mL - 1, 0) = Val(xlAppf2.ActiveSheet.Cells(kl + 1 + mL, 3))
FMidStr = FMidStr & xlAppf2.ActiveSheet.Cells(kl + 1 + mL, 2) & ","
Next
由一列数据生成比较矩阵 F头表行数 - 1, kl 'jL-1为BiL值减1，kL为用掉的行数加1
If FEndStr = "" Then
Text1 = " 运用层次分析法分析结果是：" & vbNewLine & " 耕地地力评价因子权重的不一致程度在容许范围内！"
Text1.BackColor = vbGreen
Else
Text1 = " 运用经层次分析分析结果是：" & vbNewLine & FEndStr & " 因子权重的不一致程度超过容许范围，需要重新调整！"
Text1.BackColor = vbYellow
End If
'先写表头
xlAppf2.ActiveSheet.Cells(F基准行号 - 1, 7) = "评价因素组合权重计算结果"
合并且上下左右居中 F基准行号 - 1, 7, 0, 3 + BiL(0)
xlAppf2.ActiveSheet.Cells(F基准行号, 7) = "组合层"
合并且上下左右居中 F基准行号, 7, F头表行数 - F准则层数 + 2, 0
xlAppf2.ActiveSheet.Cells(F基准行号, 8) = "目标层A"
合并且上下左右居中 F基准行号, 8, 0, 1
xlAppf2.ActiveSheet.Cells(F基准行号, 10) = "耕地地力"
合并且上下左右居中 F基准行号, 10, 0, F准则层数 - 1
For nL = 1 To F准则层数
xlAppf2.ActiveSheet.Cells(F基准行号 + 1, 10 + nL - 1) = "B" & nL
Next
xlAppf2.ActiveSheet.Cells(F基准行号, 10 + F准则层数) = "组合权重"
xlAppf2.ActiveSheet.Cells(F基准行号 + 1, 10 + F准则层数) = "∑BiCj"
xlAppf2.ActiveSheet.Cells(F基准行号 + 1, 8) = "准则层B"
合并且上下左右居中 F基准行号 + 1, 8, 1, 1
oL = 0
For nL = F基准行号 + BiL(0) + 1 To F基准行号 + F头表行数
xlAppf2.ActiveSheet.Cells(nL - BiL(0) + 2, 8) = xlAppf2.ActiveSheet.Cells(nL, 3)
xlAppf2.ActiveSheet.Cells(nL - BiL(0) + 2, 9) = xlAppf2.ActiveSheet.Cells(nL, 4)
dL = dL + xlAppf2.ActiveSheet.Cells(nL, 5)
xlAppf2.ActiveSheet.Cells(nL - 1, 10 + BiL(0)) = xlAppf2.ActiveSheet.Cells(nL, 5)
If Len(xlAppf2.ActiveSheet.Cells(nL, 3)) > 0 Then
If nL > F基准行号 + BiL(0) + 1 Then
oL = oL + 1
End If
End If
xlAppf2.ActiveSheet.Cells(nL - BiL(0) + 2, 10 + oL) = xlAppf2.ActiveSheet.Cells(nL, 5)
Next
For oL = 1 To BiL(0)
dL = 0
For nL = F基准行号 + 3 To F基准行号 + F头表行数 - BiL(0) + 3
dL = dL + xlAppf2.ActiveSheet.Cells(nL, 9 + oL)
Next
xlAppf2.ActiveSheet.Cells(F基准行号 + 2, 9 + oL) = dL
Next
nL = 3
'F基准行号34 As Integer, F准则层数3,F头表行数12
For oL = 1 To BiL(0)
合并且上下左右居中 F基准行号 + nL, 8, BiL(oL) - 1, 0
nL = nL + BiL(oL)
Next
指定范围全画表格线 F基准行号, 7, F头表行数 - BiL(0) + 2, 3 + BiL(0)
指定范围上下左右居中 F基准行号, 10, 1, BiL(0)
Command1.Caption = "打开Excel…"
Command2.SetFocus
'tRangeL.AddComment.Text "这是新添加的批注" '批注添加方法
'tRangeL.Comment.Visible = True
'最后加上保存结果的命令
If Check1.Value = 1 Then
If Not xlAppf2 Is Nothing Then
xlAppf2.DisplayAlerts = False '不提示询问是否保存
工作薄2.Save '保存
End If
End If
3.3运行结果
以新疆维吾尔自治区伊犁州伊宁县数据为例，评估一致性结果如下：
3.3.1 A层结果
因为A层、B层和组合层的分析方法相同，分析过程表就不全部列举，下边仅以A层为例列举其一致性分析结果的系列表格。
耕地地力比较矩阵和B矩阵结果表
BW矩阵、W矩阵和λ矩阵结果表
CR检验结果表
3.3.2 CR结果表
为避免不必要的重复，在此将伊宁县评价指标一致性分析结果汇集下表。
伊宁县耕地地力评价指标一致性评估结果表
上表检验结果表明，伊宁县耕地地力评价操纵杆一致性评估结果全部符合规范要求，可以直接用于开展地力评价工作。
4 小结
耕地地力评价技术中，评价指标层次分析方法是其核心技术，也是一项瓶颈技术，常因此影响其评价工作的顺利开展。许多县市均因无法开展层次分析而将其交由第三方完成，从而影响其评价工作的质量和效率。通过基于VB的层次分析方法，一个县市的耕地地力评价指标的层次分析在基础数据准备好的基础上，只需几秒种的时间，就可准确完成其全部分析，可为今后全国各地耕地地力评价工作的顺利开展提供有力的技术劫持。
参考文献：
1中华人民共和国农业行业标准《耕地地力调查与质量评价技术规程》（NY/T1634-2008）ICS 13.080.99 B 11
2 农业农村部耕地质量监测保护中心《全国耕地质量等级评价指标体系》（耕地评价函【2019】87号
3 “3414”试验数据分析软件设计原理，现代农业科技，2011年21期，隆英、席永士、邹忠
4 采样引导软件设计原理，现代农业科技，2012年9期，邹忠，周昌云
5 测土配方施肥“3414”试验的实施方法，现代农业科技，2011年22期，席永士、隆英、邹忠