Excel VBA在地理国情普查基本统计中的应用

2018-03-27龚其琛

地理空间信息 2018年3期

龚其琛，章恒

（1.中南勘察设计院（湖北）有限责任公司，湖北武汉 430000）

地理国情普查基本统计工作的主要作业成果为基本统计报告，目前基本统计报告的版本为V1.1。使用该基本统计软件能够生成基于地理国情普查数据库的各种地类长度、面积统计报表，但报表数据存放结构自成一体，且其长度、面积单位和基本统计规范所规定的报告使用单位不一致，因此人工填写报告面临两个问题，即查找数据和转换单位。通过对基本统计报告和基本统计报表的结构分析，本文采用Excel VBA编写了自动提取数据和单位转换的宏脚本，以减少人工工作量和出错率。

1 软件介绍

1）Excel。Microsoft Excel是微软公司办公软件Microsoft Office的组件之一，是Microsoft为Windows和Apple Macintosh操作系统的电脑编写和运行的一款试算表软件。Excel可进行各种数据的处理、统计分析和辅助决策操作，是微软办公组件的一个重要组成部分，被广泛地应用于管理、统计财经、金融等众多领域。

2）Excel VBA。VBA即新一代标准宏语言，是一种编程通用的自动化语言。VBA基于Visual Basic for Windows发展而来的，是Visual Basic的子集。Visual Basic是由Basic发展而来的第4代编程语言。VBA不但继承了Visual Basic的开发机制，而且与其有着相似的语言结构和开发环境。在VBA产生之前，Excel、Word等都有各自的编程语言供用户进行再开发，但语言各不相同且互不兼容，需要用户针对不同的应用软件学习各自的编程语言，这样就使得应用软件在程序上不能互联，VBA的产生圆满解决了这个问题。

2 作业思路

2.1 出图数据提取

2.1.1 作业要求

在基本统计报告编写过程中，需要制作统计对象的专题统计地图，如辖区植被覆盖、水系及道路面积等。图1为植被覆盖统计地图。

图1 基本统计报告插图样例

从图1可以看出，制作该图需要基于地理国情普查数据库中BOUA6，将出图所需的数据（图1中则是耕地、园地、林地、草地在各镇的面积以及植被覆盖占比）以镇、街为单位整理；再使用ArcGIS或其他GIS软件将数据连接到BOUA6中。各地类面积、长度数据基于基本统计软件所生成的基本统计报表提取，而基本统计报表将不同地类信息存放在不同工作表中，如图2所示，可以看出，统计信息分布规则自成体系，人工拷贝数据所需工作量较大，且容易出错。

2.1.2 作业过程

鉴于人工提取数据工作量巨大，因此本文采用Excel VBA自动提取基本统计报表中的数据，并以镇、街为单位将其一一对应，然后使用GIS软件进行属性连接并出图。其工作思路如图3所示。

图2 基本统计报表数据分布结构（部分）

图3 基本统计出图数据挂接流程图

出图流程中的核心工作为使用Excel VBA将不带属性的BOUA6图层挂接上各地类面积、长度等属性信息，用以制作各类地理图。挂接属性所需要的模板如图4所示。

图4 挂接属性模板示例（部分）

设定好挂接属性模板后，使用Excel VBA在基本统计报表中读取县、区所有镇、街名称，并放置到A列（行政区域列），然后根据行政区域中行政区域属性以及地类名称两个要素从基本统计报表各工作表中读取相应的数据。读取数据的代码为：

Private Sub CommandButton1_Click()

Application.ScreenUpdating = False

Dim i, j, m As Integer

Dim shtOutput As String

‘设定打开基本统计报表的数据框

Dim fd As FileDialog

Set fd = Application.FileDialog(msoFileDialogFilePicker)

fd.AllowMultiSelect = False

fd.Show

Workbooks.Open (fd.SelectedItems.Item(1))

shtOutput = ActiveWorkbook.Name

With Workbooks("图式属性表.xlsm").Worksheets("出图所需数据汇总")

‘获取行政区划与管理的项目数

j = 8

Do Until Workbooks(shtOutput).Sheets("地基6-5表").Cells(j, 1).Value <> "行政区划与管理"

j = j + 1

Loop

j = j - 1

‘在“出图所需数据汇总工作表”中获取各镇名称

For i = 2 To j - 6

.Cells(i, 1).Value = Workbooks(shtOutput).Worksheets("地基6-5表").Cells(i + 6, 3).Value

‘获取行政区面积

.Activate

.Range("b2").Select

ActiveCell.FormulaR1C1 = _

"=INDEX('[" & shtOutput & "]地基7-1表'!C5,MATCH(RC1,'[" & shtOutput & "]地基7-1表'!C3,0))"

.Range("b2").Select

Selection.AutoFill Destination:=.Range("b2:b50"),Type:=xlFillDefault

‘获取各镇植被覆盖数据(耕地、园地、草地、林地)

For i = 8 To 1000

Workbooks(shtOutput).Sheets("地基2-1表").Cells(i, 12).Value= Workbooks(shtOutput).Sheets("地基2-1表").Cells(i, 3).Value &Workbooks(shtOutput).Sheets("地基2-1表").Cells(i, 5).Value

.Activate

.Range("C2").Select

ActiveCell.FormulaR1C1 = _

"=INDEX('[" & shtOutput & "]地基2-1表'!C9,MATCH(RC1&R1C,'[" & shtOutput & "]地基2-1表'!C12,0))"

.Range("C2").Select

Selection.AutoFill Destination:=.Range("C2:F2"),Type:=xlFillDefault

.Range("C2:F2").Select

Selection.AutoFill Destination:=.Range("C2:F50"),Type:=xlFillDefault

‘获取各镇水域数据

For i = 8 To 1000

Workbooks(shtOutput).Sheets("地基3-3表").Cells(i, 12).Value= Workbooks(shtOutput).Sheets("地基3-3表").Cells(i, 3).Value &Workbooks(shtOutput).Sheets("地基3-3表").Cells(i, 5).Value

（其他地类提取代码略过）

End With

Workbooks(shtOutput).Close True

Application.ScreenUpdating = True

MsgBox ("完成")

End Sub

在Excel 中设置宏快捷键或插入宏激活按钮连接此段代码，即可对基本统计报表中数据进行自动提取，运行过程及效果图如图5、6所示。

图5 数据提取宏运行截图

图6 数据提取宏运行结果（部分）

采用插入宏ActiveX按钮的方式激活宏代码，开始运行之后选取相应的基本统计报表，点击“打开”自动运行并提取数据，数据提取结果如图6所示，将各地类面积、长度等属性以镇、街为单位汇总成表，建立BOUA6层NAME字段与此表行政区域的对应关系，可轻易地把地类属性连接起来用于出图。

2.2 单位转换

2.2.1 作业要求

基本统计过程中，需要使用到基本统计软件生成的基本统计报表，但基本统计技术规范规定基本统计报告中面积单位均采用km2且保留3位小数，而基本统计报表中单位为m2；基本统计报告中长度均采用km且保留两位小数，而基本统计报表中单位为m。若在编写报告时直接基于基本统计报表进行人工转换，既容易出错又会花费较大的时间成本，因此采用Excel VBA的形式编写单位转换、自动取位代码，将转换出来的数据直接复制使用。

2.2.2 作业过程

使用Excel VBA编写的单位转换模块运行界面如图7所示。

图7 单位转换模块截图

将编写完成的单位转换宏设置为快捷键（如Ctrl+S），在报告编写过程中，需要使用报表中的面积时，将待进行单位转换的单元格选中，按下Ctrl+S，在跳出的对话框中选择“m2-km2”即可在报表的最后一行自动生成单位转换后且已自动取位的面积，m转km也是相同的操作方法。延长小数位选项用于报表中保留两位小数的面积占比等不需要转换单位的数值，由于基本统计规范要求保留两位小数，在保留两位会将大于0的数值保留为0.00的情况下，此选项能自动延长小数位以保证面积占比大于0。其详细代码为：

Private Sub OptionButton1_Click()

‘m-km

On Error Resume Next

Dim i As Integer

Dim rg As Range

With ActiveWorkbook.ActiveSheet

i = .Range("a8").CurrentRegion.Columns.Count + 1

For Each rg In Selection

‘若单位转换成果取两位小数不为0则直接取位

If CDbl(rg.Value) / 1000 >= 0.005 Then

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) / 1000 +0.0000001, 2)

Else

‘若单位转换成果取两位小数为0，则通过NumberCal函数判定小数点后第一个有效数字位数灵活取位

j = NumberCal(CDbl(rg.Value) / 1000)

If Round(CDbl(rg.Value) / 1000 + 0.0000000000001, j - 1) =0# Then

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) / 1000 +0.000000001, j)

Else

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) / 1000 +0.000000001, j - 1)

End If

End With

UserForm1.Hide

End Sub

Private Sub OptionButton2_Click()

‘m2- km2

On Error Resume Next

Dim i, j As Integer

Dim rg As Range

With ActiveWorkbook.ActiveSheet

i = .Range("a8").CurrentRegion.Columns.Count + 1

For Each rg In Selection

‘若单位转换成果取3位小数不为0则直接取位

If CDbl(rg.Value / 1000000) >= 0.0005 Then

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) / 1000000+ 0.00000001, 3)

Else

‘若单位转换成果取3位小数为0，则通过NumberCal函数判定小数点后第一个有效数字位数灵活取位

j = NumberCal(CDbl(rg.Value) / 1000000)

If Round(CDbl(rg.Value) / 1000000 + 0.0000000000001, j -1) = 0# Then

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) / 1000000+ 0.000000001, j)

Else

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) / 1000000+ 0.000000001, j - 1)

End If

End With

UserForm1.Hide

End Sub

Private Sub OptionButton3_Click()

‘延长小数位

On Error Resume Next

Dim i As Integer

Dim rg As Range

With ActiveWorkbook.ActiveSheet

i = .Range("a8").CurrentRegion.Columns.Count + 1

For Each rg In Selection

‘若数值取两位小数不为0则直接取位

If CDbl(rg.Value) >= 0.005 Then

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) +0.000000001, 2)

Else

‘若数值取两位小数为0，则通过NumberCal函数判定小数点后第一个有效数字位数灵活取位

j = NumberCal(CDbl(rg.Value))

If Round(CDbl(rg.Value) + 0.0000000000001, j - 1) = 0#Then

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) +0.00000000001, j)

Else

.Cells(rg.Row, i).Value = Round(CDbl(rg.Value) +0.00000000001, j - 1)

End If

End With

UserForm1.Hide

End Sub

Public Function NumberCal(ByVal a As Double) As Integer

‘使用正则表达式检索有效数字位数的方式判定取位为0的数值小数点后第一次出现非0值的位置

Dim oRegExp As Object

Dim oMatches As Object

Dim i, j As Integer

Dim s As String

s = CStr(a)

Set oRegExp = CreateObject("vbscript.regexp")

With oRegExp

.Global = False

.Pattern = "[1-9]"

Set oMatches = .Execute(s)s = .Replace(s, "b")

i = InStr(s, ".")

j = InStr(s, "b")

End With

NumberCal = j - i

End Function

该宏代码将“m-km”、“m2-km2”、“延长小数位”分作3个模块编写，各模块均用到一个NumberCal函数。该函数是一个自定义函数，通过正则表达式搜索1～9数值的方式查找数值小数点后第一个有效数字的位置，从而解决把较小小数取位为0.00或0.000的问题。

3 结语

本文通过在解决基本统计作业过程中遇到的数据提取与单位转换问题，展示了VBA在处理Excel格式数据中的巨大应用潜力，将项目需求与Excel VBA相结合，在很多时候能极大地减少冗余工作量。Excel具有灵活、规范的数据处理能力，与ArcGIS等地理处理软件能很好的互补，熟练掌握对日常的地理信息化作业有很大帮助。

[1] Microsoft Excel VBA 2010帮助文件[CP].美国:微软公司,2009

[2] 罗刚君. Excel VBA程序开发自学宝典 [M].第2版.北京:电子工业出版社,2009

[3] 魏汪洋. Excel VBA语法速查手册[M].北京:化学工业出版社,2011

[4] 罗刚君. Excel VBA范例大全[M].北京:电子工业出版社,2008

[5] 王健. Excel表格直接转换为MapGIS中报表的方法[J].地理空间信息,2010,8(5):144-145

[6] 朱向荣.基于Excel VBA的常用测量计算问题解决方案[J].地理空间信息,2013,11(5):131-133

[7] 李德仁,邵振峰,丁霖.地理国情信息的多级网格化表达[J].地理空间信息,2014,12(1):1-5