平时工作中,经常会遇到调查表汇总或者报表汇总的问题。比如近期,作为主管部门,要搞一次整个系统的员工基本情况调查,如果调查单位数量很少,可以通过复制、粘贴的方法,把调查数据复制到同一个工作簿中,然后通过公式进行汇总。可是,如果调查单位有几百个、几千个,并且每张表的数据又很多,使用这种方法就显得非常麻烦。下面的方法可以让你摆脱烦恼,一劳永逸。
第1步:
在E盘根目录下新建一个“报表汇总”文件夹(“报表汇总”文件夹可以建立在任意驱动器的任意文件夹中),并在该文件夹中再新建一个“基层表1”文件夹(各调查单位上报的调查表全部复制到这个文件夹中)。
第2步:
运行Excel,首先把3个工作表的名称分别改为“汇总表”“初始设置”、“过渡表”,然后在工作表“汇总表”中设计所需要的调查表(或报表,下同),并在该工作表中增加一个“汇总”按钮,按钮名称为默认的CommandButton1。设计完成后,保存在“报表汇总”文件夹中,文件名称自定。假如文件名称是“报表汇总1”。
第3步:
根据不同的情况,在“初始设置”工作表的B1:B6单元格中设置不同的内容。其中:“提示内容所在单元格”用于确定提示内容“正在汇总,请稍等。。。”的显示位置。
工作表“过渡表”中没有任何数据,仅仅用于导入各调查单位上报的数据。汇总结束后,该表数据全部清除。
第4步:
在按钮“汇总”的单击事件中粘贴以下代码:
Private Sub CommandButton1_Click() '报表汇总通用代码 Dim TotalUnitNum As Integer, StartRng As String, bDataRows As Byte, bDataColumns As Byte, TipsRng As String With Sheets("初始设置") TotalUnitNum = .[B2]: StartRng = .[B3]: bDataRows = .[B4]: bDataColumns = .[B5]: TipsRng = .[B6] End With Dim DataPath As String, FileName() As String, iUnitNum As Integer DataPath = ThisWorkbook.Path & "\" & Sheets("初始设置").Range("B1") & "\" ReDim Preserve FileName(0) FileName(0) = Dir(DataPath & "*.xls") Do While FileName(iUnitNum) <> "" iUnitNum = iUnitNum + 1 ReDim Preserve FileName(iUnitNum) FileName(iUnitNum) = Dir Loop If iUnitNum <> TotalUnitNum Then '调查表不全 If iUnitNum = 0 Then MsgBox "无任何调查表数据!", vbOKOnly + vbInformation, "退出" Exit Sub End If If MsgBox("调查表不全,是否强行汇总?", vbYesNo + vbQuestion + vbDefaultButton2, "提示") = vbNo Then Exit Sub End If Dim sTmp sTmp = Range(TipsRng) '保存提示内容所在单元格原有值,这样可把提示内容设在任何单元格中 Range(TipsRng) = "正在汇总,请稍等。。。" '“过渡表”第 1 行赋值为:行编号、Data1、Data2、Data3、Data4、Data5。。。 Dim i As Integer With Sheets("过渡表") .Range("A1") = "行编号" For i = 1 To bDataColumns .Cells(1, i + 1) = "Data" & i Next End With '把每个单位的调查表数据导入B2开始的单元格区域中 Dim SourceBook As Object, SourceSheet As Object, Arr, j As Integer, Start As Single Start = Timer Application.ScreenUpdating = False Application.ShowWindowsInTaskbar = False For i = 0 To UBound(FileName) - 1 '因为最后一个FileName数组为空,所以要-1 Set SourceBook = Workbooks.Open(DataPath & FileName(i), 0, True) '假如每个单位的调查表数据均在名称为“Sheet1”的工作表中。 On Error GoTo TableErr Set SourceSheet = SourceBook.Worksheets("Sheet1") On Error GoTo 0 Arr = SourceSheet.Range(StartRng).Resize(bDataRows, bDataColumns) SourceBook.Close False With Sheets("过渡表") .Range("B" & (2 + i * bDataRows)).Resize(bDataRows, bDataColumns) = Arr For j = 1 To bDataRows '每导入一个调查单位的数据,其数据行的“行编号”字段值分别设为R001、R002、R003......等等 '这样,才能使用SQL语言按关键字段“行编号”进行分组统计。 '之所以要增加关键字段“行编号”,是为下面的分组统计的需要。因为下面如果按指标名称进行 '分组统计的话,指标名称可能会有重复。比如,“人员总量”中列出“其中:女性”这一指标, '“按专业技术职称分”中,也可能有“其中:女性”这一指标。这种情况下按指标名称进行分组 '统计时,统计结果就不正确了。 .Range("A" & (1 + j + i * bDataRows)) = "R" & Right("00" & j, 3) Next End With Next Set SourceSheet = Nothing Set SourceBook = Nothing Dim Cnn As Object, SQL As String Set Cnn = CreateObject("ADODB.Connection") 'Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;data Source=" & ThisWorkbook.FullName Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;imex=1;';data Source=" & ThisWorkbook.FullName '如果数据区域(不包括标题行和指标名称列的区域)中任何一列的前8个单元格均为空白,分组求和的结果都不正确。 '解决办法:要么在Extended Properties中加参数imex=1,要么先把这一列第一个单元格的值改为0。 '在此感谢ExcelHome论坛jyhxr、zhaogang1960等老师的帮助。 SQL = "select " For i = 1 To bDataColumns SQL = SQL & "Sum(Data" & i & ")," Next 'SQL = Left(SQL, Len(SQL) - 1) & " from [过渡表$A1:" & Chr(65 + bDataColumns) & (1 + bDataRows * iUnitNum) & "] group by 行编号" SQL = Left(SQL, Len(SQL) - 1) & " from [过渡表$A1:" & _ Left(Cells(1, CInt(bDataColumns + 1)).Address(0, 0), Len(Cells(1, CInt(bDataColumns + 1)).Address(0, 0)) - 1) & _ (1 + bDataRows * iUnitNum) & "] group by 行编号" 'Range(StartRng).Resize(bDataRows, bDataColumns).CopyFromRecordset Cnn.Execute(SQL) Range(StartRng).CopyFromRecordset Cnn.Execute(SQL) Cnn.Close Set Cnn = Nothing
Sheets("过渡表").Range("A1").Resize(bDataRows * iUnitNum + 1, bDataColumns + 1).ClearContents Range(TipsRng) = sTmp Application.ShowWindowsInTaskbar = True Application.ScreenUpdating = True MsgBox "报表汇总结束,用时 " & Round(Timer - Start, 0) & " 秒!", vbOKOnly, "结束" Exit Sub TableErr: Range(TipsRng) = sTmp MsgBox "工作簿“" & SourceBook.Name & "”中没有需要汇总的工作表," & vbCr & _ "或者,该工作表的名称被用户擅自修改了。" & vbCr & vbCr & _ "请检查后再进行汇总!", vbOKOnly + vbExclamation, "错误提示" SourceBook.Close False End Sub
第5步:
为防止调查对象擅自修改表格结构,比如,随意增加或删除行、列,就会导致汇总出来的结果不正确。因此,有必要对工作表设置保护。你可以通过菜单栏进行设置,也可粘贴以下代码到工作表“汇总表”的VBE窗口中,并直接运行“保护工作表”这个过程。
Sub 保护工作表() Dim StartRng As String, bDataRows As Byte, bDataColumns As Byte, Rng As Range With Sheets("初始设置") StartRng = .[B3]: bDataRows = .[B4]: bDataColumns = .[B5] End With ActiveSheet.Unprotect Password:="123" '解除对工作表的保护(假设原保护密码是123) '选中整个表格,添加锁定 Cells.Select Selection.Locked = True '选取数据区域,解除锁定 Set Rng = Range(StartRng & ":" & ColumnConv(ColumnConv(Left(StartRng, 1)) + bDataColumns - 1) & (Right(StartRng, 1) + bDataRows - 1)) Rng.Select Selection.Locked = False ActiveSheet.Protect Password:="123" '保护工作表,并设置密码为123 ActiveSheet.EnableSelection = xlUnlockedCells '让锁定单元格不能选中 Range(StartRng).Select End Sub
Function ColumnConv(SpecStr As String) As String If IsNumeric(SpecStr) Then ColumnConv = Left(Cells(1, CInt(SpecStr)).Address(0, 0), Len(Cells(1, CInt(SpecStr)).Address(0, 0)) - 1) Else ColumnConv = Range(SpecStr & 1).Column End If End Function
至此,表格设计及相关代码编写全部结束。
第6步:
制作下发的调查表。把该工作簿复制一份,打开复制的工作簿,删除其中的“初始设置”和“过渡表”两个工作表,并把工作表“汇总表”的名称改为“Sheet1”(代码中认可的工作表名称是Sheet1),删除其中的VBA代码。好了,就把这个工作簿发给调查对象填写吧。
最后再作两点说明:
1、要解除作为汇总表的工作表保护。因为,如果提示内容设置在数据区域以外的单元格中显示,运行时由于有工作表保护会出现错误提示。
2、文件夹的名称以及各单位上报的调查表的名称可随便命名。
|