Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3704|回复: 7

[已解决]多个工作簿数据合并到一个工作簿

[复制链接]
发表于 2013-12-24 14:33 | 显示全部楼层 |阅读模式
我有很多个工作簿,工作簿里面只有一个工作表,或者有多个工作表。工作簿里面的工作表数量不等,有的多,有的少。但是字段名是一样的。我在合并工作簿里面要实现的效果就是这个工作簿数据合并到一个共用的工作簿的工作表里面即可。字段都是统一的。
详细见附件。
数据.rar (32.36 KB, 下载次数: 34)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-12-24 15:01 | 显示全部楼层
  1. Sub 合并()

  2.     Dim strPath As String, strFile As String
  3.     Dim blHeader As Boolean
  4.     Dim arr
  5.     Dim header
  6.     Dim sht As Worksheet
  7.     strPath = ThisWorkbook.Path & Application.PathSeparator
  8.     strFile = Dir(strPath & "*.xls")
  9.     With Worksheets(1)
  10.         On Error Resume Next
  11.         .UsedRange.Clear
  12.     End With
  13.     Application.ScreenUpdating = False
  14.     Application.DisplayAlerts = False
  15.     Application.EnableEvents = False

  16.     Do While Len(strFile)
  17.         If strFile <> ThisWorkbook.Name Then

  18.             With GetObject(strPath & strFile)
  19.                 For Each sht In .Worksheets
  20.                     With sht
  21.                         If .Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
  22.                             If Not blHeader Then
  23.                                 header = .UsedRange.Rows(1).Value
  24.                             End If

  25.                             With Worksheets(1)
  26.                                 .Range("a1").Resize(, UBound(header, 2)).Value = header
  27.                                 blHeader = True
  28.                             End With
  29.                             arr = .Range(.Range("a2"), .Range("a1").End(xlDown).End(xlToRight)).Value
  30.                             With Worksheets(1)
  31.                                 .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)).Value = arr
  32.                             End With
  33.                         End If
  34.                     End With
  35.                 Next
  36.                 Windows(.Name).Visible = True
  37.                 .Close True
  38.             End With
  39.         End If
  40.         strFile = Dir
  41.     Loop
  42.     With Worksheets(1)
  43.         With .UsedRange
  44.             If .Rows.Count > 1 Then
  45.                 .Borders.LineStyle = 1
  46.                 .EntireColumn.AutoFit
  47.             End If

  48.         End With
  49.     End With
  50.     Application.ScreenUpdating = True
  51.     MsgBox "合并完成"
  52. End Sub
复制代码
回复

使用道具 举报

发表于 2013-12-24 15:03 | 显示全部楼层
  1. Sub 合并()
  2.     Dim strPath As String, strFile As String
  3.     Dim blHeader As Boolean
  4.     Dim arr
  5.     Dim header
  6.     Dim sht As Worksheet
  7.     strPath = ThisWorkbook.Path & Application.PathSeparator
  8.     strFile = Dir(strPath & "*.xls")
  9.     With Worksheets(1)
  10.         On Error Resume Next
  11.         .UsedRange.Clear
  12.     End With
  13.     Application.ScreenUpdating = False
  14.     Application.DisplayAlerts = False
  15.     Application.EnableEvents = False

  16.     Do While Len(strFile)
  17.         If strFile <> ThisWorkbook.Name Then

  18.             With GetObject(strPath & strFile)
  19.                 For Each sht In .Worksheets
  20.                     With sht
  21.                         If .Cells(Rows.Count, 1).End(xlUp).Row > 1 Then
  22.                             If Not blHeader Then
  23.                                 header = .UsedRange.Rows(1).Value
  24.                                 With Worksheets(1)
  25.                                     .Range("a1").Resize(, UBound(header, 2)).Value = header
  26.                                     blHeader = True
  27.                                 End With
  28.                             End If
  29.                             arr = .Range(.Range("a2"), .Range("a1").End(xlDown).End(xlToRight)).Value
  30.                             With Worksheets(1)
  31.                                 .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)).Value = arr
  32.                             End With
  33.                         End If
  34.                     End With
  35.                 Next
  36.                 Windows(.Name).Visible = True
  37.                 .Close True
  38.             End With
  39.         End If
  40.         strFile = Dir
  41.     Loop
  42.     With Worksheets(1)
  43.         With .UsedRange
  44.             If .Rows.Count > 1 Then
  45.                 .Borders.LineStyle = 1
  46.                 .EntireColumn.AutoFit
  47.             End If

  48.         End With
  49.     End With
  50.     Application.ScreenUpdating = True
  51.     MsgBox "合并完成"
  52. End Sub
复制代码
回复

使用道具 举报

发表于 2013-12-24 15:08 | 显示全部楼层
请测试:
数据.rar (31.25 KB, 下载次数: 45)
回复

使用道具 举报

发表于 2013-12-24 15:09 | 显示全部楼层
本帖最后由 tgydslr 于 2013-12-24 15:11 编辑
  1. Sub UnionWorksheets()
  2. Application.ScreenUpdating = False
  3. Dim lj As String
  4. Dim dirname As String
  5. Dim nm As String
  6. Dim i As Integer, ii As Integer
  7. lj = ActiveWorkbook.path
  8. nm = ActiveWorkbook.Name
  9. dirname = Dir(lj & "\*.xls")
  10. Cells.Clear

  11. Do While dirname <> ""
  12. If dirname <> nm Then
  13. Workbooks.Open Filename:=lj & "" & dirname
  14. ii = ActiveWorkbook.Sheets.Count
  15. Workbooks(nm).Activate
  16. '复制新打开工作簿的每一个工作表的已用区域到当前工作表
  17. For i = 1 To ii
  18. Workbooks(dirname).Sheets(i).UsedRange.Copy _
  19. Range("a65536").End(xlUp).Offset(2, 0)
  20. Next
  21. Workbooks(dirname).Close False
  22. End If
  23. dirname = Dir
  24. Loop

  25. End Sub
复制代码

数据.rar

27.88 KB, 下载次数: 13

回复

使用道具 举报

发表于 2013-12-24 15:13 | 显示全部楼层    本楼为最佳答案   
  1. Sub 合并()
  2.     Dim strPath As String, strFile As String
  3.     Dim blHeader As Boolean
  4.     Dim arr
  5.     Dim header
  6.     Dim sht As Worksheet
  7.     strPath = ThisWorkbook.Path & Application.PathSeparator
  8.     strFile = Dir(strPath & "*.xls")
  9.     With Worksheets(1)
  10.         On Error Resume Next
  11.         .UsedRange.Clear
  12.     End With
  13.     Application.ScreenUpdating = False
  14.     Application.DisplayAlerts = False

  15.     Do While Len(strFile)
  16.         If strFile <> ThisWorkbook.Name Then
  17.             With GetObject(strPath & strFile)
  18.                 For Each sht In .Worksheets
  19.                     With sht
  20.                         If .UsedRange.Rows.Count > 1 Then
  21.                             If Not blHeader Then
  22.                                 header = .UsedRange.Rows(1).Value
  23.                                 With Worksheets(1)
  24.                                     .Range("a1").Resize(, UBound(header, 2)).Value = header
  25.                                     blHeader = True
  26.                                 End With
  27.                             End If
  28.                             arr = .Range("a2:" & Split(.UsedRange.Address, ":")(1)).Value
  29.                             With Worksheets(1)
  30.                                 .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)).Value = arr
  31.                             End With
  32.                         End If
  33.                     End With
  34.                 Next
  35.                 Windows(.Name).Visible = True
  36.                 .Close True
  37.             End With
  38.         End If
  39.         strFile = Dir
  40.     Loop
  41.     With Worksheets(1)
  42.         With .UsedRange
  43.             If .Rows.Count > 1 Then
  44.                 .Borders.LineStyle = 1
  45.                 .EntireColumn.AutoFit
  46.             End If

  47.         End With
  48.     End With
  49.     Application.ScreenUpdating = True
  50.     Application.DisplayAlerts = True
  51.     MsgBox "合并完成"
  52. End Sub
复制代码
回复

使用道具 举报

发表于 2013-12-25 17:59 | 显示全部楼层
昨天失误,改正下代码。
  1. Sub 合并()
  2.     Dim strPath As String, strFile As String
  3.     Dim blHeader As Boolean
  4.     Dim arr
  5.     Dim header
  6.     Dim sht As Worksheet
  7.     strPath = ThisWorkbook.Path & Application.PathSeparator
  8.     strFile = Dir(strPath & "*.xls")
  9.     With Worksheets(1)
  10.         On Error Resume Next
  11.         .UsedRange.Clear
  12.     End With
  13.     Application.ScreenUpdating = False
  14.     Application.DisplayAlerts = False

  15.     Do While Len(strFile)
  16.         If strFile <> ThisWorkbook.Name Then
  17.             With GetObject(strPath & strFile)
  18.                 Application.StatusBar = "正在处理 " & .FullName
  19.                 For Each sht In .Worksheets
  20.                     With sht
  21.                         If .UsedRange.Rows.Count > 1 Then
  22.                             If Not blHeader Then
  23.                                 header = .UsedRange.Rows(1).Value
  24.                                 With Worksheets(1)
  25.                                     .Range("a1").Resize(, UBound(header, 2)).Value = header
  26.                                     blHeader = True
  27.                                 End With
  28.                             End If
  29.                             arr = .Range("a2:" & Split(.UsedRange.Address, ":")(1)).Value
  30.                             With Worksheets(1)
  31.                                 .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr), UBound(arr, 2)).Value = arr
  32.                             End With
  33.                         End If
  34.                     End With
  35.                 Next
  36.                 Windows(.Name).Visible = True
  37.                 .Close False
  38.             End With
  39.         End If
  40.         strFile = Dir
  41.     Loop
  42.     Application.StatusBar = ""
  43.     With Worksheets(1)
  44.         With .UsedRange
  45.             If .Rows.Count > 1 Then
  46.                 .Borders.LineStyle = 1
  47.                 .EntireColumn.AutoFit
  48.             End If

  49.         End With
  50.     End With
  51.     Application.ScreenUpdating = True
  52.     Application.DisplayAlerts = True
  53.     MsgBox "合并完成"
  54. End Sub
复制代码
回复

使用道具 举报

发表于 2014-5-23 13:49 | 显示全部楼层
好复杂
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 19:58 , Processed in 0.785331 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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