在财政全覆盖审计的前期工作中，审计人员通过大数据分析会取得若干审计疑点表，需要将疑点按单位分发至各组核实，传统做法是筛选、复制、粘贴后形成各个单位的疑点数据再分发，该方法重复性高，效率低。面对数据量大、单位多时很容易忙中出错，那么如何快速准确地切割数据，提高审计工作效率呢？笔者以全覆盖审计分析为例，运用EXCEL VBA函数和批处理BAT文件实现大数据的高效切割归类，供广大同仁参考借鉴。
基本思路是利用VBA函数先将所有疑点表按单位名称切割到一个新文件夹下，再运用批处理BAT文件将所有已分割好的疑点表按单位名称归类到以单位名称命名的文件夹里。
步骤一：在文件夹里新建一个xls文件和一个文件夹，本次将xls文件命名为“遍历文件夹下所有工作簿所有工作表并将工作表拆分为单独工作簿.xls”，文件夹命名为“源数据”。
步骤二：将大数据分析得到的疑点表拷贝到“源数据”这个文件夹里，同时新建一个文件夹，命名为“拆分文件夹”。检查所有疑点表，确定每张表的A列内容是单位名称。
步骤三：打开“遍历文件夹下所有工作簿所有工作表并将工作表拆分为单独工作簿.xls”，创建模块，添加执行按钮，显示操作结果。
1.工作表名右键—查看代码。
2.插入—模块，添加函数，保存后关闭。
具体代码如下：
Sub拆分单独表()'拆分多个工作簿和每个工作表
Dim Sht As Worksheet, Sh As Worksheet, book &, dw &, p$, f$, Keystr, bt, arr'定义变量
Dim MyFile As Object, dic As Object'定义类型
Application.ScreenUpdating=False'关闭屏幕更新
On Error Resume Next'忽略代码运行中可能出现的错误继续运行
With Application.FileDialog(msoFileDialogFolderPicker)'取得用户选择的文件夹路径
.AllowMultiSelect=False
If.Show Then
p=.SelectedItems(1)'将用户选择的文件夹路径赋值给p
Else
Exit Sub'退出程序
End If
End With
If Right(p，1)＜＞""Then p=p & "\"'如果文件夹路径的最后一个字符不等于空，则连接一个"\"
Set MyFile=CreateObject("Scripting.FileSystemObject")'调用组件以便获取路径
If MyFile.folderexists(p & "拆分文件夹")Then'判断文件夹是否存在
ReturnValue=MsgBox("文件夹已存在，是否更新内容？"，vbOKCancel，"Caution!")存在则提示
If ReturnValue=2 Then Exit Sub'选择取消则退出程序
Else
MyFile.CreateFolder(p & "拆分文件夹")'创建文件夹
Set MyFile=Nothing'释放内存
End If
Keystr=InputBox("请输入需要拆分的工作表所包含的关键词："，"提醒")'工作表关键字，可设置关键字只对包含关键字的工作表进行操作。要操作所有表则保持为空
If StrPtr(Keystr)=0 Then Exit Sub'如果点击了inputbox的取消或者关闭按钮，则退出程序
Set Sht=ActiveSheet'标记当前表
Cells.ClearContents'清空当前表数据
Cells.NumberFormat="@"'设置当前表为文本格式
bt=Split("工作簿名，拆分工作表名，拆分后文件名"，"，")设置标题
[a1].Resize(1，3)=bt'输入标题
f=Dir(p & "*.xls*")'开始遍历工作簿
Do While f＜＞""'如果文件名不等于空就一直循环
If f＜＞ThisWorkbook.Name Then'避免同名文件重复打开出错
With GetObject(p & f)'以'只读'形式读取文件时，使用getobject方法会比workbooks.open稍快
FolderName=Mid(f,1,InStrRev(f,"."，Len(f))-1)'取得工作簿名
For Each Sh In.Worksheets'遍历表
If InStr(1,Sh.Name,Keystr, vbTextCompare)Then'如果表中包含关键词则进行操作(不区分关键词字母大小写)
book=book+1'记录一下Sheet个数
Set dic=CreateObject("scripting.dictionary")'创建字典
For i=2 To Sh.Cells(Rows.Count, 1).End(xlUp).Row'读取A列最大行数
dic(Sh.Cells(i，1).Value)=1'合并A列重复项并装入字典
Nexti'循环A列
arr=dic.keys'将字典中处理好的数据装入数组arr
Sh.Range("al").AutoFilter'开启自动筛选
Fori=0 To UBound(arr)'循环数组
dw=dw+1'记录拆分新文件个数
Sh.Range("al").CurrentRegion.AutoFilter Field：=1, Criteria1：="="& arr(i)'按数组进行筛选
Sh.Range("A1").CurrentRegion.Copy'复制筛选后数据
Workbooks.Add'创建新工作簿
ActiveSheet.Range("A1").PasteSpecial Paste：=xIPPasteValues'粘贴到新工作簿第一个表的A1单元格
Application.CutCopyMode=False'清空剪切板释放内存
ActiveSheet.[a1].Select'选中A1单元格
ActiveSheet.Columns("A：G").EntireColumn.AutoFit'自动调整列宽
ActiveWorkbook.SaveAs Filename：=p & "拆分文件夹"& "\"& arr(i)& "_"& FolderName & "-"& Sh.Name & ".xls"'另存为到根目录创建的文件夹
ActiveWorkbook.Close True'关闭并保存工作簿
Sht.Cells(dw+1，1)=FolderName'将工作簿名输出到主表
Sht.Cells(dw+1，2)=Sh.Name'将工作表名输出到主表
Sht.Cells(dw+1,3)=arr(i)&"-"& FolderName &"-"& Sh.Name'将新工作簿名输出到主表
Sht.Hyperlinks.Add Anchor：=Sht.Cells(dw+1,3)，Address：=p & "拆分文件夹"&"\"& arr(i)& "_" & Folder-Name & "-" & Sh.Name & ".xls", TextToDisplay：=arr(i)& "_" & FolderName & "-" & Sh.Name'建立超链接，方便查看表
Next i'循环拆分
Sh.Range("a1").AutoFilter'取消自动筛选
End If
Next'循环工作表
.Close False'关闭工作簿
End With
End If
f=Dir'下一个表格
Loop'循环工作簿
MsgBox"拆分完成。"
Set Sh=Nothing'释放内存
Set Sht=Nothing'释放内存
Set dic=Nothing'释放内存
Application.ScreenUpdating=True'恢复屏幕更新
End Sub
3.在工作表中添加执行按钮，显示操作结果。
步骤四：单击执行按钮执行模块，运行结束后，拆分的疑点表保存在“拆分文件夹”里，效果如下：
21个疑点表，1.24MB，运行8分59秒27.，被拆分成1 146个新表，命名规则是“单位名称-原工作簿名称-原工作表名称”。
步骤五：在“拆分文件夹里”新建一个文本文件，命名为“利用批处理来根据文件名自动建立对应文件夹”。
1.打开文本文件，输入以下代码。
@echo off
setlocalenabledelayedexpansion
for/f "tokens=1,2*delims=_"%%a in('dir/a-d/b')
do(
md "%%～a"
move "%%～a_%%～b""%%～a\"
)
pause
第三行指定“_”划分文件名，第四行建立指定文件夹，第五行将符合命名规则的文件移动到对应文件夹。
2.保存后修改文件后缀名为bat，双击执行。
1146个新表全部批量移动到以单位名称命名的343个对应文件夹里，效果示例如下：
以上方法是笔者在财政全覆盖审计中总结的一点心得，前期编写代码比较耗时，但后期处理数据非常快捷，可能原来需耗费几周时间才可以完成的工作现在不到15分钟就全部精准完成。此方法适用于其他审计中各类数据的汇总，只需根据表格的不同对代码进行小改动即可适用。
