ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 跨表格合并成新的一个新表格

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-8-18 00:22 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
请各位老师们帮忙看看能不能实现。一个文件夹下有多个不同名字,但是内容里的格式完全相同的表格,我想把这些表格汇总到一个带表头的总表里,具体的内容我,放在附件了!因为以后可能要处理500左右的表格合并!请老师多帮忙!

跨表合并.zip

21.23 KB, 下载次数: 17

TA的精华主题

TA的得分主题

发表于 2017-8-18 06:23 | 显示全部楼层
简单的多簿单表合并而已,这样的实例比比皆是,你找过吗?

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-8-18 06:33 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
lsc900707 发表于 2017-8-18 06:23
简单的多簿单表合并而已,这样的实例比比皆是,你找过吗?

我把相关的帖子差不多都看了,但是确实是门外汉,试验了几次都没成功!清大侠帮忙!

TA的精华主题

TA的得分主题

发表于 2017-8-18 06:36 | 显示全部楼层
本帖最后由 lsc900707 于 2017-8-18 06:45 编辑
xilaba123 发表于 2017-8-18 06:33
我把相关的帖子差不多都看了,但是确实是门外汉,试验了几次都没成功!清大侠帮忙!

你要学会给别人评分:点击帮助者帖子右下角“评分”即可。
Sub lqt()
t = Timer
Dim brr(1 To 100000, 1 To 11)
myPath = ThisWorkbook.Path & "\"
MyName = Dir(myPath & "*.xls*")
Application.ScreenUpdating = False
Do While MyName <> ""
    If MyName <> ThisWorkbook.Name Then
        n = n + 1
        Set sh = GetObject(myPath & MyName).Sheets(1)
        Arr = sh.UsedRange
        Workbooks(MyName).Close False
        For i = 1 To UBound(Arr)
            If Len(Arr(i, 1)) <> 0 Then
                m = m + 1
                For j = 1 To 11
                    brr(m, j) = Arr(i, j)
                Next
            End If
        Next
      End If
      MyName = Dir
Loop
Set sh = Nothing
With Sheet1
     .Rows("2:100000").ClearContents
     .[a2].Resize(m, UBound(brr, 2)).Value = brr
End With
Application.ScreenUpdating = True
MsgBox "汇总了:" & n & "个工作表;共有:" & m & "行数据。" & "用时:" & Format(Timer - t, "0.00") & "秒"
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-8-18 07:13 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2017-8-18 07:15 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助

代码审核中,请耐心等待。

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-8-18 07:16 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
lsc900707 发表于 2017-8-18 07:15
代码审核中,请耐心等待。

万分感谢您的出手相助!

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-8-18 07:18 | 显示全部楼层
lsc900707 发表于 2017-8-18 07:15
代码审核中,请耐心等待。

大侠,合并每个excel的第一个工作簿就可以了!

TA的精华主题

TA的得分主题

发表于 2017-8-18 08:27 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim wb As Workbook
  4.   Dim ws As Worksheet
  5.   Dim mypath$, myname$
  6.   Application.ScreenUpdating = False
  7.   Application.DisplayAlerts = False
  8.   mypath = ThisWorkbook.Path & ""
  9.   myname = Dir(mypath & "*.xlsx")
  10.   With Worksheets("sheet1")
  11.     .UsedRange.Offset(1, 0).Clear
  12.   End With
  13.   Set ws0 = Worksheets("sheet1")
  14.   Do While myname <> ""
  15.     If myname <> ThisWorkbook.Name Then
  16.       Set wb = GetObject(mypath & myname)
  17.       With wb
  18.         With .Worksheets(1)
  19.           r = .Cells(.Rows.Count, 1).End(xlUp).Row
  20.           .Range("a2:k" & r).Copy ws0.Cells(ws0.Rows.Count, 1).End(xlUp).Offset(1, 0)
  21.         End With
  22.         .Close False
  23.       End With
  24.     End If
  25.     myname = Dir
  26.   Loop
  27. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2017-8-18 08:27 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
详见附件。

跨表合并.rar

40.06 KB, 下载次数: 25

评分

1

查看全部评分

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

本版积分规则

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

GMT+8, 2024-3-29 18:06 , Processed in 0.044931 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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