VBA汇总

第一、将多张工作表中的数据合并到一张工作表中

Sub hebing()  '把各班成绩表中的记录合并到"成绩表"工作表中
    Dim sht As Worksheet
    Set sht = Worksheets("成绩表")
    
    sht.Rows("2:65536").Clear      '删除成绩表中的原有记录
    
    Dim wt As Worksheet, xrow As Integer, rng As range
    
    For Each wt In Worksheets                   '循环处理宏所在工作簿中的每张工作表
    
        If wt.Name <> "成绩表" Then
        '如果要执行的sheet名不为成绩表则执行以下语句，即不是成绩表的工作表顺序执行
        
            Set rng = sht.range("A1048576").End(xlUp).Offset(1, 0)
            '找到成绩表A列第一个空单元格
            'Range("A1048576")代表A列最后一行
            'End(xlUp)代表A列最后一个非空单元格
            'Offset(1, 0)代表最后一个非空单元格向下一行即第一个空单元格
            
            xrow = wt.range("A1").CurrentRegion.Rows.Count - 1
            'xrow等于-选中sheet的A1在内的一个连续的矩形区域的行数-1
            
            wt.range("A2").Resize(xrow, 7).Copy rng
            '然后，将该sheet的A2单元格扩展为xrow行7列的单元格区域，将以上区域复制到rng单元格的位置
            
        End If    
    Next  
end sub

第二、将多个工作簿中的数据合并到同一张工作表中

Sub HzWb()
    Dim bt As Range, r As Long, c As Long
    r = 1                                       '1 是表头的行数
    c = 7                                       '7 是表头的列数
    Dim wt As Worksheet
    Set wt = ThisWorkbook.Worksheets(1)         '将汇总表赋给变量wt
    
    wt.Rows(r + 1 & ":1048576").ClearContents   '清除汇总表中原表数据,只保留表头
    
    Application.ScreenUpdating = False
    
    Dim FileName As String, sht As Worksheet, wb As Workbook
    Dim Erow As Long, fn As String, arr As Variant
    FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
    
    Do While FileName <> ""
    
        If FileName <> ThisWorkbook.Name Then                  ' 判断文件是否是汇总数据的工作簿
            Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1 ' 取得汇总表中第一条空行行号
            fn = ThisWorkbook.Path & "\" & FileName            ' 将第1个要汇总的工作簿名称赋给变量fn
            Set wb = GetObject(fn)                             ' 将变量fn 代表的工作簿对象赋给变量wb
            Set sht = wb.Worksheets(1)                         ' 将要汇总的工作表赋给变量sht
                                                               ' 将工作表中要汇总的记录保存在数组arr里
            arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "B").End(xlUp).Offset(0, 5)) ' 将数组arr 中的数据写入工作表
            wt.Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            wb.Close False
        End If
        
        FileName = Dir                            ' 用Dir 函数取得其他文件名，并赋给变量
        
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

第三、将工作簿中的每张工作表都保存为单独的工作簿文件

Sub HzWb()
    Dim bt As Range, r As Long, c As Long
    r = 1                                       '1 是表头的行数
    c = 7                                       '7 是表头的列数
    Dim wt As Worksheet
    Set wt = ThisWorkbook.Worksheets(1)         '将汇总表赋给变量wt
    
    wt.Rows(r + 1 & ":1048576").ClearContents   '清除汇总表中原表数据,只保留表头
    
    Application.ScreenUpdating = False
    
    Dim FileName As String, sht As Worksheet, wb As Workbook
    Dim Erow As Long, fn As String, arr As Variant
    FileName = Dir(ThisWorkbook.Path & "\*.xlsx")
    
    Do While FileName <> ""
    
        If FileName <> ThisWorkbook.Name Then                  ' 判断文件是否是汇总数据的工作簿
            Erow = wt.Range("A1").CurrentRegion.Rows.Count + 1 ' 取得汇总表中第一条空行行号
            fn = ThisWorkbook.Path & "\" & FileName            ' 将第1个要汇总的工作簿名称赋给变量fn
            Set wb = GetObject(fn)                             ' 将变量fn 代表的工作簿对象赋给变量wb
            Set sht = wb.Worksheets(1)                         ' 将要汇总的工作表赋给变量sht
                                                               ' 将工作表中要汇总的记录保存在数组arr里
            arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(1048576, "B").End(xlUp).Offset(0, 5)) ' 将数组arr 中的数据写入工作表
            wt.Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
            wb.Close False
        End If
        
        FileName = Dir                            ' 用Dir 函数取得其他文件名，并赋给变量
        
    Loop
    
    Application.ScreenUpdating = True
    
End Sub