VBA实现将所有数据表中的内容合并到一张新的数据表中

最新推荐文章于 2024-12-19 11:37:40 发布

HappyDelano

最新推荐文章于 2024-12-19 11:37:40 发布

阅读量443

点赞数 1

CC 4.0 BY-SA版权

文章标签： vba

本文链接：https://blog.csdn.net/liu_zhen_wei/article/details/143747794

Attribute VB_Name = "NewMacros"
Option Explicit
Public Const Const_OutSheetName As String = "VBA汇总"

Sub 汇总V2()
Attribute 汇总V2.VB_Description = "宏由 LiuZW 录制，时间: 2023/08/19"
Attribute 汇总V2.VB_ProcData.VB_Invoke_Func = " 14"
'
' 汇总 Macro
' 宏由 LiuZW 录制，时间: 2023/08/19

    Dim i As Integer
       
    
    '判断是否已有“VBA汇总”数据表
    For i = 1 To Worksheets.Count
        If Worksheets(i).name = Const_OutSheetName Then
            MsgBox ("要生成的数据表“" + Const_OutSheetName + "”存在同名数据表，请修改或删除同名数据表后重试。")
            Exit Sub
        End If
    Next
    
    '选中第一个数据表，以使得生成的汇总表在最前面，便于查阅
    Application.Worksheets(1).Activate
    
    '创建“VBA汇总”数据表
    Sheets.Add
    ActiveSheet.name = Const_OutSheetName
    Columns("A:A").Select
    Selection.NumberFormatLocal = "@"
    
      
    '复制各个数据表的数据并粘贴到汇总表
    For i = 1 To Worksheets.Count
        Dim mSheetName As String
        mSheetName = Worksheets(i).name
        
        '如果当前数据表不是 无需汇总的数据表，就执行汇总
        If Worksheets(i).name <> Const_OutSheetName Then
        
            '执行复制和粘贴
            Application.Worksheets(mSheetName).Activate
            Dim mUsedRowCount, mUsedColumnCount As Integer
            mUsedRowCount = ActiveSheet.UsedRange.Rows.Count
            mUsedColumnCount = ActiveSheet.UsedRange.Columns.Count
            Application.Worksheets(mSheetName).Range(Cells(1, 1), Cells(mUsedRowCount, mUsedColumnCount)).Select
            Selection.Copy
            
            '判断要粘贴的位置并粘贴
            Application.Worksheets(Const_OutSheetName).Activate
            Dim usableRowCount As Integer
            usableRowCount = Application.Application.Sheets(Const_OutSheetName).Range("b65536").End(xlUp).Row + 2
            Application.Worksheets(Const_OutSheetName).Cells(usableRowCount, 2).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False
            
            '填充第一列
            Dim k As Integer
            For k = 0 To mUsedRowCount
                Application.Worksheets(Const_OutSheetName).Cells(usableRowCount + k, 1).Value = mSheetName
            Next
            
        End If
    Next
    
    MsgBox ("数据表内容汇总已完成，请在最左侧 《VBA汇总》 数据表中查阅汇总数据。")
End Sub