ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

如何将多个工作簿(其中每个里面有多个工作表)中特定的工作表合并在一个工作簿中

[复制链接]

TA的精华主题

TA的得分主题

发表于 2021-2-8 18:18 | 显示全部楼层 |阅读模式
如何将多个工作簿(其中每个里面有多个工作表)中特定的工作表合并在一个工作簿中
有多个工作簿,格式都一样,内有多个工作表,需要提取其中包含“2020”的工作表,并将它们汇总在一个工作簿的一个工作表中。
试了网上很多vba的代码都不行,求大神解答

实验用.rar

19.78 KB, 下载次数: 49

TA的精华主题

TA的得分主题

发表于 2021-2-8 19:34 | 显示全部楼层
Option Explicit

Sub test() '现成的
  Dim Cn As Object, Rs As Object, Ca As Object, Tb As Object, d As Object, Sq$, p$, f$, s$(1), i&, j&, k&
  Cells.ClearContents
  Application.ScreenUpdating = False
  Set d = CreateObject("Scripting.Dictionary")
  s(0) = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
  Set Cn = CreateObject("ADODB.Connection")
  Cn.Open s(0) & ThisWorkbook.FullName
  Set Ca = CreateObject("ADOX.Catalog")
  p = ThisWorkbook.Path & "\"
  f = Dir(p & "*.xls*")
  Do While f <> ""
    If f <> ThisWorkbook.Name Then
      Ca.ActiveConnection = s(0) & p & f
      For Each Tb In Ca.Tables
        If Tb.Type = "TABLE" Then
          s(1) = Replace(Tb.Name, "'", "")
          If Right(s(1), 1) = "$" Then
            If InStr(s(1), "2020") Then
              Sq = "SELECT * FROM [Excel 12.0;Database=" & p & f & "].[" & s(1) & "A1:b] WHERE LEN(姓名)"
              d(Sq) = ""
              k = k + 1
              If k Mod 49 = 0 Then
                i = i + 1: Sq = Join(d.Keys, " UNION ALL "): d.RemoveAll
                Set Rs = Cn.Execute(Sq)
                If i = 1 Then
                  For j = 0 To Rs.Fields.Count - 1
                    Range("A1").Offset(0, j) = Rs.Fields(j).Name
                  Next
                End If
                Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
              End If
            End If
          End If
        End If
      Next
      Ca.ActiveConnection = Nothing
    End If
    f = Dir
  Loop
  If d.Count Then
    Sq = Join(d.Keys, " UNION ALL ")
    Set Rs = Cn.Execute(Sq)
    If i = 0 Then
      For j = 0 To Rs.Fields.Count - 1
        Range("A1").Offset(0, j) = Rs.Fields(j).Name
      Next
    End If
    Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
  End If
  Cn.Close: Set Cn = Nothing: Set Rs = Nothing: Set Tb = Nothing: Set Ca = Nothing: Set d = Nothing
  Application.ScreenUpdating = True
  Beep
End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2021-2-8 19:36 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
实验用.rar (39.11 KB, 下载次数: 187)

TA的精华主题

TA的得分主题

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

十分感谢,确实是我想要的效果,但是有几个问题,一个代码里面那些是可以修改的变量呢,我刚刚试了试改了下就报错。

TA的精华主题

TA的得分主题

发表于 2021-2-9 18:31 | 显示全部楼层
whwhat 发表于 2021-2-9 10:07
十分感谢,确实是我想要的效果,但是有几个问题,一个代码里面那些是可以修改的变量呢,我刚刚试了试改了 ...

要附件,至少要把标题截个图。

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2021-2-9 18:35 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2021-3-23 21:52 | 显示全部楼层
我说句话,你给的数据示例一点都不诚心。这么个破表,别人怎么帮你。把表的结构给人家,人家才能帮你。你自己想想对不对。

TA的精华主题

TA的得分主题

发表于 2021-8-14 09:27 | 显示全部楼层
xiangbaoan 发表于 2021-2-8 19:34
Option Explicit

Sub test() '现成的

您好!我一直在用你编写的这个代码,省了大量的时间,而且非常准确,您能抽时间改一下代码吗?实现由原来的粘贴内容由上到下排列,改成粘贴后由左向右排列,请见附件“实验用01.rar”,非常感谢您!

实验用01.rar

26.34 KB, 下载次数: 18

TA的精华主题

TA的得分主题

发表于 2021-8-14 09:52 | 显示全部楼层
wpeidong 发表于 2021-8-14 09:27
您好!我一直在用你编写的这个代码,省了大量的时间,而且非常准确,您能抽时间改一下代码吗?实现由原来 ...

实验用01.rar (37.71 KB, 下载次数: 133)

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2021-8-14 10:02 | 显示全部楼层
wpeidong 发表于 2021-8-14 09:27
您好!我一直在用你编写的这个代码,省了大量的时间,而且非常准确,您能抽时间改一下代码吗?实现由原来 ...

您好!您更改后的代码完全符合要求,真的太感谢您了!谢谢!谢谢!谢谢!

评分

1

查看全部评分

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

本版积分规则

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

GMT+8, 2024-3-29 16:51 , Processed in 0.065881 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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