excel vba 将多张数据表的内容合并到一张数据表

功能描述:

一个Excel文件有很多个 样式相同 的数据表,

需要将多张数据表的内容合并到一张数据表里。

vba实现代码如下:

vbnet 复制代码
Attribute VB_Name = "NewMacros"
Option Explicit
Public Const Const_OutSheetName As String = "VBA汇总"
Public Const Const_PZSheetName As String = "配置"

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

'

    Dim i, j, k As Integer
        
    
    '创建"配置"数据表并提示用户填写配置
    Dim isExistPZ As Boolean
    isExistPZ = False
    For i = 1 To Worksheets.Count
        If Worksheets(i).name = Const_PZSheetName Then
            isExistPZ = True
            Exit For
        End If
    Next
    
    '定义表示要复制的区域的变量
    Dim mRow1, mColumn1, mRow2, mColumn2 As Integer
        
    If isExistPZ Then
        mRow1 = Application.Worksheets(Const_PZSheetName).Range("B2").Value
        mRow2 = Application.Worksheets(Const_PZSheetName).Range("B3").Value
        mColumn1 = Application.Worksheets(Const_PZSheetName).Range("B4").Value
        mColumn2 = Application.Worksheets(Const_PZSheetName).Range("B5").Value
       
       If mRow1 = 0 Or mRow2 = 0 Or mColumn1 = 0 Or mColumn2 = 0 Then
       
            '提示用户填写
            MsgBox ("请填写配置数据表后运行。")
            Exit Sub
       End If
       
       '配置的填写有效性判断
       If Not IsNumeric(mRow1) Or Not IsNumeric(mRow2) Or Not IsNumeric(mColumn1) Or Not IsNumeric(mColumn2) Then
            MsgBox ("配置数据表中键入的区域表述无效,请键入数字格式的行列号。")
            Exit Sub
       End If
       
    
    Else
        '创建"配置"数据表
        Sheets.Add
        ActiveSheet.name = Const_PZSheetName
        
        '填写基础信息
        Application.Worksheets(Const_PZSheetName).Range("A1").Value = "不需要汇总的数据表名称"
        Application.Worksheets(Const_PZSheetName).Range("B1").Value = Const_PZSheetName
        Application.Worksheets(Const_PZSheetName).Range("C1").Value = Const_OutSheetName
        Application.Worksheets(Const_PZSheetName).Range("A2").Value = "复制区域的起始行"
        Application.Worksheets(Const_PZSheetName).Range("A3").Value = "复制区域的终止行"
        Application.Worksheets(Const_PZSheetName).Range("A4").Value = "复制区域的起始列"
        Application.Worksheets(Const_PZSheetName).Range("A5").Value = "复制区域的终止列"
        
        '提示用户填写
        MsgBox ("请填写配置数据表后运行。")
        Exit Sub
    End If
    
    '判断是否已有"VBA汇总"数据表
    For i = 1 To Worksheets.Count
        If Worksheets(i).name = Const_OutSheetName Then
            MsgBox ("要生成的数据表"" + Const_OutSheetName + ""存在同名数据表,请修改或删除同名数据表后重试。")
            Exit Sub
        End If
    Next
    
    '创建"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
        
        '判断当前数据表是否为 无需汇总的数据表
        'MsgBox ("当前数据表的第一行一共有" + CStr(Application.CountA(Sheets(Const_PZSheetName).Rows(1))) + "个数据")
        
        '定义当前数据表是否为 无需汇总的数据表 的标记,True表示无需汇总,False表示需要汇总
        Dim mKey As Boolean
        mKey = False
        
        For j = 2 To Application.CountA(Sheets(Const_PZSheetName).Rows(1))
            If mSheetName = Sheets(Const_PZSheetName).Cells(1, j) Then
                'MsgBox ("当前数据表"" + mSheetName + ""是不需要汇总的数据表")
                mKey = True
                Exit For
            End If
        Next
        
        '如果当前数据表不是 无需汇总的数据表,就执行汇总
        If mKey = False Then
        
            '执行复制和粘贴
            
            
            
            Application.Worksheets(mSheetName).Activate
            Application.Worksheets(mSheetName).Range(Cells(mRow1, mColumn1), Cells(mRow2, mColumn2)).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
            
            '填充第一列
            For k = 0 To mRow2 - mRow1
                Application.Worksheets(Const_OutSheetName).Cells(usableRowCount + k, 1).Value = mSheetName
            Next
            
        End If
    Next
End Sub

文件链接:数据表合并.bas

下载后直接在excel 查看代码处导入文件即可。

相关推荐
excel11 分钟前
ES6 中函数的双重调用方式:fn() 与 fn\...``
前端
可乐爱宅着23 分钟前
全栈框架next.js入手指南
前端·next.js
你的人类朋友2 小时前
什么是API签名?
前端·后端·安全
会豪4 小时前
Electron-Vite (一)快速构建桌面应用
前端
中微子4 小时前
React 执行阶段与渲染机制详解(基于 React 18+ 官方文档)
前端
唐某人丶4 小时前
教你如何用 JS 实现 Agent 系统(2)—— 开发 ReAct 版本的“深度搜索”
前端·人工智能·aigc
中微子4 小时前
深入剖析 useState产生的 setState的完整执行流程
前端
遂心_4 小时前
JavaScript 函数参数传递机制:一道经典面试题解析
前端·javascript
小徐_23334 小时前
uni-app vue3 也能使用 Echarts?Wot Starter 是这样做的!
前端·uni-app·echarts
RoyLin5 小时前
TypeScript设计模式:适配器模式
前端·后端·node.js