网站建设服务标语在线图片制作生成器

功能描述： 

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

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

vba实现代码如下：

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 BooleanisExistPZ = FalseFor i = 1 To Worksheets.CountIf Worksheets(i).name = Const_PZSheetName ThenisExistPZ = TrueExit ForEnd IfNext'定义表示要复制的区域的变量Dim mRow1, mColumn1, mRow2, mColumn2 As IntegerIf isExistPZ ThenmRow1 = Application.Worksheets(Const_PZSheetName).Range("B2").ValuemRow2 = Application.Worksheets(Const_PZSheetName).Range("B3").ValuemColumn1 = Application.Worksheets(Const_PZSheetName).Range("B4").ValuemColumn2 = Application.Worksheets(Const_PZSheetName).Range("B5").ValueIf mRow1 = 0 Or mRow2 = 0 Or mColumn1 = 0 Or mColumn2 = 0 Then'提示用户填写MsgBox ("请填写配置数据表后运行。")Exit SubEnd If'配置的填写有效性判断If Not IsNumeric(mRow1) Or Not IsNumeric(mRow2) Or Not IsNumeric(mColumn1) Or Not IsNumeric(mColumn2) ThenMsgBox ("配置数据表中键入的区域表述无效，请键入数字格式的行列号。")Exit SubEnd IfElse'创建“配置”数据表Sheets.AddActiveSheet.name = Const_PZSheetName'填写基础信息Application.Worksheets(Const_PZSheetName).Range("A1").Value = "不需要汇总的数据表名称"Application.Worksheets(Const_PZSheetName).Range("B1").Value = Const_PZSheetNameApplication.Worksheets(Const_PZSheetName).Range("C1").Value = Const_OutSheetNameApplication.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 SubEnd If'判断是否已有“VBA汇总”数据表For i = 1 To Worksheets.CountIf Worksheets(i).name = Const_OutSheetName ThenMsgBox ("要生成的数据表“" + Const_OutSheetName + "”存在同名数据表，请修改或删除同名数据表后重试。")Exit SubEnd IfNext'创建“VBA汇总”数据表Sheets.AddActiveSheet.name = Const_OutSheetNameColumns("A:A").SelectSelection.NumberFormatLocal = "@"'复制各个数据表的数据并粘贴到汇总表For i = 1 To Worksheets.CountDim mSheetName As StringmSheetName = Worksheets(i).name'判断当前数据表是否为 无需汇总的数据表'MsgBox ("当前数据表的第一行一共有" + CStr(Application.CountA(Sheets(Const_PZSheetName).Rows(1))) + "个数据")'定义当前数据表是否为 无需汇总的数据表 的标记，True表示无需汇总，False表示需要汇总Dim mKey As BooleanmKey = FalseFor j = 2 To Application.CountA(Sheets(Const_PZSheetName).Rows(1))If mSheetName = Sheets(Const_PZSheetName).Cells(1, j) Then'MsgBox ("当前数据表“" + mSheetName + "”是不需要汇总的数据表")mKey = TrueExit ForEnd IfNext'如果当前数据表不是 无需汇总的数据表，就执行汇总If mKey = False Then'执行复制和粘贴Application.Worksheets(mSheetName).ActivateApplication.Worksheets(mSheetName).Range(Cells(mRow1, mColumn1), Cells(mRow2, mColumn2)).SelectSelection.Copy'判断要粘贴的位置并粘贴Application.Worksheets(Const_OutSheetName).ActivateDim usableRowCount As IntegerusableRowCount = Application.Application.Sheets(Const_OutSheetName).Range("b65536").End(xlUp).Row + 2Application.Worksheets(Const_OutSheetName).Cells(usableRowCount, 2).SelectSelection.PasteSpecial Paste:=xlPasteValues, Operation:=xlPasteSpecialOperationNone, SkipBlanks:=False, Transpose:=False'填充第一列For k = 0 To mRow2 - mRow1Application.Worksheets(Const_OutSheetName).Cells(usableRowCount + k, 1).Value = mSheetNameNextEnd IfNext
End Sub

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

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