VBA在统计中运用浅尝
王益树
四川省广汉市新丰镇
【摘要】办公中往往要遇到重复的数据收集，但如果使用复制、粘贴的办法会繁琐而易出错，机器也吃不消，运用VBA可能获得事半功倍的效果。
【关键词】VBA 数据
自泰勒时代开始，数学与统计在生产管理科学的不断进步中就一直居于支配地位。作为一名涉及有关数据统计人员，不但需要学习各种先进的管理理念，更需要学习这些理念的实战应用方法。
本次在针对“国家学生体质健康标准数据管理”数据处理时，尝试运用VBA来进行统计，使用我再次认识到它的便利，大大提高了工作效率。
工作情况：本校共27个班，900百余人，每收集数据20余项。如（图一）
（图一）
工作思路：首先生成以班为单位含个人信息的独立表格；其次分发给每位体育教师进行填写；最后收集汇总。
首先，在全校学生信息中写入VBA代码：
Option Explicit
Sub ExtractReps()
Dim ws1 As Worksheet
Dim wsNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Sheet1")
Set rng = Range("Database")
'extract a list of Sales Reps
ws1.Columns("C:C").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("V1"), Unique:=True
r = Cells(Rows.Count, "V").End(xlUp).Row
'set up Criteria Area
Range("X1").Value = Range("C1").Value
For Each c In Range("V2:V" & r)
'add the rep name to the criteria area
ws1.Range("X2").Value = c.Value
'add new sheet and run advanced filter
Set wsNew = Sheets.Add
wsNew.Move After:=Worksheets(Worksheets.Count)
wsNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Sheet1").Range("X1:X2"), _
CopyToRange:=wsNew.Range("A1"), _
Unique:=False
Next
ws1.Select
ws1.Columns("V:X").Delete
End Sub
执行后生成（图二）
（图二）
再把每一个工作簿生成独立的EXCLE文件，写入VBA代码：
Sub 另存所有工作表为工作簿()
Dim sht As Worksheet
Application.ScreenUpdating = False '禁用屏幕刷新
ipath = ThisWorkbook.Path & "\" '当前工作簿的文件目录
For Each sht In Sheets
sht.Copy
ActiveWorkbook.SaveAs ipath & sht.Name & ".xls" '(工作表名称为文件名）
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub
执行后生成（图三）
（图三）
其次，把生成的文件分发给每位填写人员，进行数据数据录入，核对。
最后，在空表中写入VBA代码：
Sub Silent_open1()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long, J As Long
Dim Num As Long
Dim BOX As String
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
BOX = InputBox("请输入您要合并的工作表号，以阿拉伯数值为准。" & Chr(13) & Chr(13) & _
"如要合并工作簿的第2张工作表，则输入“2”。" & Chr(13) & Chr(13) & _
"默认值为“1”。", "输入", 1)
If BOX = "" Then
Exit Sub
ElseIf IsNumeric(BOX) = False Then
MsgBox "请输入数值型数据。", vbCritical, "Error"
Exit Sub
ElseIf Val(BOX) <> Int(Val(BOX)) Then
MsgBox "请输入整数。", vbCritical, "Error"
Exit Sub
ElseIf Val(BOX) < 0 Then
MsgBox "请输入正整数。", vbCritical, "Error"
Exit Sub
ElseIf Val(BOX) > 255 Then
MsgBox "输入数据超过工作表的最大取值范围。", vbCritical, "Error"
Exit Sub
End If
Application.ScreenUpdating = False
J = BOX
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
G = Sheets.Count
If J > G Then
Wb.Close False
Application.ScreenUpdating = True
MsgBox "您所输入的值超出工作簿" & Chr(13) & MyName & Chr(13) & _
"的工作表范围，因此强制推出。", vbCritical, "Error"
Exit Sub
End If
.Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
Wb.Sheets(J).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄的第" & J & "张工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub
执行（图四）
显示（图五）
（图五）
最后生成（图六），导入生成数据到“国家学生体质健康标准数据管理”，完成任务。
（图六）
VBA的运用，使得工作变得轻松，避免了通过复制、粘贴完成任务此任务时造成的机器运行困难，人为操作不当时数据在过程中的丢失或错误，也为下次更好完成工作任务而做好准备。
参考文献：
(1)Excel 2003高级VBA编程宝典
(2)Excel 2003与VBA编程从入门到精通(中文版)
(3)巧学巧用Excel 2003 VBA与宏(中文版)
(4)ExcelVBA应用程序专业设计实用指南
(5)ExcelVBA应用开发与实例精讲
(6)一些网上资源
|
