黑色玻璃球:Excel报表汇总通用代码

    平时工作中，经常会遇到调查表汇总或者报表汇总的问题。比如近期，作为主管部门，要搞一次整个系统的员工基本情况调查，如果调查单位数量很少，可以通过复制、粘贴的方法，把调查数据复制到同一个工作簿中，然后通过公式进行汇总。可是，如果调查单位有几百个、几千个，并且每张表的数据又很多，使用这种方法就显得非常麻烦。下面的方法可以让你摆脱烦恼，一劳永逸。

    第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、要解除作为汇总表的工作表保护。因为，如果提示内容设置在数据区域以外的单元格中显示，运行时由于有工作表保护会出现错误提示。