ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 8613|回复: 11

[求助] 怎样合并表头相同的多张excel表格????

[复制链接]

TA的精华主题

TA的得分主题

发表于 2014-11-25 16:40 | 显示全部楼层 |阅读模式
怎样合并表头相同的多张excel表格????请大侠们帮忙指导下,谢谢了!!!!!!!!!!

TA的精华主题

TA的得分主题

发表于 2014-11-25 16:48 | 显示全部楼层
下载excel必备工具箱,里面有文件合并、表格合并等选项。

TA的精华主题

TA的得分主题

发表于 2014-11-25 17:08 | 显示全部楼层
上传个具体示例,以便有针对性地帮你出出主意!

TA的精华主题

TA的得分主题

发表于 2014-11-25 17:11 | 显示全部楼层
SQL可以实际,具体需要传附件上来

TA的精华主题

TA的得分主题

发表于 2014-11-25 18:50 来自手机 | 显示全部楼层
可以用合并计算,SQL,某些计算直接用公式也可以的。

TA的精华主题

TA的得分主题

发表于 2014-12-14 13:36 | 显示全部楼层
以一个excel表为基准,把其他几个excel表逐个选中---在选中区域右键单击--复制--打开为基准excel表格-在基准excel表格右下空白区域单元格区域右键单击--粘贴--(其他依次相同方法)
头像被屏蔽

TA的精华主题

TA的得分主题

发表于 2014-12-14 21:40 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
提示: 作者被禁止或删除 内容自动屏蔽

TA的精华主题

TA的得分主题

发表于 2018-10-20 15:42 | 显示全部楼层
本帖最后由 ·#天蝎#· 于 2018-10-20 16:25 编辑

我在网上找了些,加上我自己的修改,试着做了个合并多张表头、格式相同的表格文件的VBA,请各位大侠批评指正。Sub 多工作簿合并()
  Dim HeadRows As Byte, ActiveWB As Workbook, cell As Range
  Dim bks As Workbook
  Dim fdg As FileDialog
  Dim FileName$
  Dim p As String

  UserForm1.ListBox9.Clear
  Set fdg = Application.FileDialog(msoFileDialogFilePicker)
  With fdg
    .Title = "请选择文件(可以多选)"
    .AllowMultiSelect = True 'False表示不能选择多个文件,True表示可以选择多个文件
    .Filters.Clear
    .Filters.Add "表格文件", "*.xls;*.et;*.xlsx"
    FileName = .Show
      For i = 1 To .SelectedItems.Count
    UserForm1.ListBox9.AddItem (.SelectedItems(i))
    Next i
  End With
  If fdg.SelectedItems.Count = 0 Then Exit Sub
  Set fdg = Nothing

  On Error Resume Next
  Set ActiveWB = ActiveWorkbook  '将活动工作簿赋予变量
  Set bks = Workbooks.Add
  HeadRows = Application.InputBox("请确认待合并工作簿的标题行数,该行将产生在合并工作簿中做为新的标题行:", "标题行", 1, , , , , 1) '让用户指定标题行数,标题不参与合并
  If HeadRows < 1 Then Exit Sub  '如果标题行小于1则退出程序
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual '计算模式调用手动,从而提速
For j = 0 To UserForm1.ListBox9.ListCount - 1
    UserForm1.ListBox9.ListIndex = j
    UserForm1.ListBox9.Selected(j) = True
    nm = UserForm1.ListBox9.List(UserForm1.ListBox9.ListIndex, 0)
    Workbooks.Open FileName:=nm
    bm = ActiveWorkbook.Name
    ActiveWB.Activate  '返回存放合并数据的工作表
bks.Worksheets(1).Activate
    If j = 1 Then Intersect(Workbooks(nm).Sheets(1).UsedRange, Workbooks(nm).Sheets(1).Rows("1:" & HeadRows)).Copy bks.Worksheets(1).Cells(1, 1) '如果j=1,那么将标题复制到活动工作表a1
    For i = 1 To Workbooks(nm).Sheets.Count '遍历所有工作表,开始合并标题以外的数据
      With Workbooks(nm).Sheets(i).UsedRange '引用待合并工作簿中每个工作表的已用区域
        If Not IsEmpty(Workbooks(nm).Sheets(i).UsedRange) Then '如果非空表
          If .Rows.Count <= HeadRows Then GoTo lines  '如果数据行小于等于标题行数则执行下轮循环
          Set cell = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1) '将活动工作表已用区域的下一行第3个单元格赋予变量
          Intersect(.Offset(HeadRows, 0), .Cells).Copy cell '将目标数据除标题外全部复制到cell单元格(此次复制,仅仅需要其格式)
        End If
        Cells.EntireColumn.AutoFit '自动调整行高列宽
      End With
lines:
    Next i  '合并下一个工作表
    Workbooks(nm).Close False '并闭工作簿,且不保存
   With UserForm0
              .Show 0
              .Label2.Width = Int(j / (UserForm1.ListBox9.ListCount - 1) * 282)
              .Label3.Caption = bm
              .Caption = "正在合并:" & bm
              .Label4.Caption = CStr(Int(j / (UserForm1.ListBox9.ListCount - 1) * 100)) + "%"
              DoEvents
     End With
Next j
MkDir PathStr & "\" & "合并表\"
bks.SaveAs FileName:=PathStr & "\" & "合并表\" & Left(bm, Len(bm) - 4) & "等表合并" & ".et"
bks.Close True
Set bks = Nothing
Unload UserForm0
  On Error Resume Next
Application.WindowState = xlMinimized
  MsgBox ("请查看合并好的表格!")
  Shell "Explorer.exe " & PathStr & "\" & "合并表\", vbMaximizedFocus
  UserForm1.Hide
  Application.ScreenUpdating = True  '恢复屏幕更新
  Application.Calculation = xlCalculationAutomatic  '恢复自动计算
End Sub


TA的精华主题

TA的得分主题

发表于 2018-10-20 15:43 | 显示全部楼层
本帖最后由 ·#天蝎#· 于 2018-10-20 16:31 编辑

Sub 多工作簿合并()
  Dim HeadRows As Byte, ActiveWB As Workbook, cell As Range
  Dim bks As Workbook
  Dim fdg As FileDialog
  Dim FileName$
  Dim p As String
  
  UserForm1.ListBox9.Clear
  Set fdg = Application.FileDialog(msoFileDialogFilePicker)
  With fdg
    .Title = "请选择文件(可以多选)"
    .AllowMultiSelect = True 'False表示不能选择多个文件,True表示可以选择多个文件
    .Filters.Clear
    .Filters.Add "表格文件", "*.xls;*.et;*.xlsx"
    FileName = .Show
      For i = 1 To .SelectedItems.Count
    UserForm1.ListBox9.AddItem (.SelectedItems(i))
    Next i
  End With
  If fdg.SelectedItems.Count = 0 Then Exit Sub
  Set fdg = Nothing
  
  On Error Resume Next
  Set ActiveWB = ActiveWorkbook  '将活动工作簿赋予变量
  Set bks = Workbooks.Add
  HeadRows = Application.InputBox("请确认待合并工作簿的标题行数,该行将产生在合并工作簿中做为新的标题行:", "标题行", 1, , , , , 1) '让用户指定标题行数,标题不参与合并
  If HeadRows < 1 Then Exit Sub  '如果标题行小于1则退出程序
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual '计算模式调用手动,从而提速
For j = 0 To UserForm1.ListBox9.ListCount - 1
    UserForm1.ListBox9.ListIndex = j
    UserForm1.ListBox9.Selected(j) = True
    nm = UserForm1.ListBox9.List(UserForm1.ListBox9.ListIndex, 0)
    Workbooks.Open FileName:=nm
    bm = ActiveWorkbook.Name
    ActiveWB.Activate  '返回存放合并数据的工作表
bks.Worksheets(1).Activate
    If j = 1 Then Intersect(Workbooks(nm).Sheets(1).UsedRange, Workbooks(nm).Sheets(1).Rows("1:" & HeadRows)).Copy bks.Worksheets(1).Cells(1, 1) '如果j=1,那么将标题复制到活动工作表a1
    For i = 1 To Workbooks(nm).Sheets.Count '遍历所有工作表,开始合并标题以外的数据
      With Workbooks(nm).Sheets(i).UsedRange '引用待合并工作簿中每个工作表的已用区域
        If Not IsEmpty(Workbooks(nm).Sheets(i).UsedRange) Then '如果非空表
          If .Rows.Count <= HeadRows Then GoTo lines  '如果数据行小于等于标题行数则执行下轮循环
          Set cell = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1) '将活动工作表已用区域的下一行第3个单元格赋予变量
          Intersect(.Offset(HeadRows, 0), .Cells).Copy cell '将目标数据除标题外全部复制到cell单元格(此次复制,仅仅需要其格式)
        End If
        Cells.EntireColumn.AutoFit '自动调整行高列宽
      End With
lines:
    Next i  '合并下一个工作表
    Workbooks(nm).Close False '并闭工作簿,且不保存
   With UserForm0
              .Show 0
              .Label2.Width = Int(j / (UserForm1.ListBox9.ListCount - 1) * 282)
              .Label3.Caption = bm
              .Caption = "正在合并:" & bm
              .Label4.Caption = CStr(Int(j / (UserForm1.ListBox9.ListCount - 1) * 100)) + "%"
              DoEvents
     End With
Next j
MkDir PathStr & "\" & "合并表\"
bks.SaveAs FileName:=PathStr & "\" & "合并表\" & Left(bm, Len(bm) - 4) & "等表合并" & ".et"
bks.Close True
Set bks = Nothing
Unload UserForm0
  On Error Resume Next
Application.WindowState = xlMinimized
  MsgBox ("请查看合并好的表格!")
  Shell "Explorer.exe " & PathStr & "\" & "合并表\", vbMaximizedFocus
  UserForm1.Hide
  Application.ScreenUpdating = True  '恢复屏幕更新
  Application.Calculation = xlCalculationAutomatic  '恢复自动计算
End Sub

TA的精华主题

TA的得分主题

发表于 2024-5-9 20:13 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-23 20:18 , Processed in 0.035526 second(s), 9 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表