ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 分表数据复制到汇总表

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-10-18 11:06 | 显示全部楼层 |阅读模式
1、同一文件夹,分表数据复制到汇总表
2、不打开分表

新建文件夹.zip

5.82 KB, 下载次数: 19

求复制汇总

TA的精华主题

TA的得分主题

发表于 2018-10-18 11:16 | 显示全部楼层
Dim arr(), s&
Sub 多簿多表合并为一表()
   Dim MyPath, MyName, AWbName
    Dim wb As Workbook, WbN As String
    Dim G As Long
    Dim Num As Long
    Dim BOX As String
    bth = Val(Application.InputBox("请输入表头占据了的行数:", "拆分表格", "1"))
    bw = Val(Application.InputBox("请输入表尾行数:", "拆分表格", "0"))
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    MyPath = ThisWorkbook.Path
  s = 0
  Zdir ThisWorkbook.Path
For Each hhl In arr
    If hhl <> "" Then
    MyName = Dir(hhl)
    AWbName = ThisWorkbook.Name
        If MyName <> AWbName And MyName <> "" Then
            Set wb = Workbooks.Open(hhl)
            With Workbooks(1).ActiveSheet
             For G = 1 To wb.Sheets.Count
                tqgzb = wb.Sheets(G).Name
                lh = wb.Sheets(G).UsedRange.Columns.Count + wb.Sheets(G).UsedRange.Column - 1
                 hh = wb.Sheets(G).Range("a65535").End(xlUp).Row
                  k = k + 1
                 If k = 1 Then
                   wb.Sheets(G).Range("a1").Resize(hh - bw, lh).Copy .Cells(.Range("a65535").End(xlUp).Row + n, 2)
                   hh1 = Workbooks(1).ActiveSheet.UsedRange.Rows.Count + Workbooks(1).ActiveSheet.UsedRange.Row - 1
                   .Cells(bth, 1) = "数据来源"
                   .Range(.Cells(bth + 1, 1), .Cells(hh1, 1)) = MyName & "-" & tqgzb
                 n = (n + 1) ^ 0
                 Else
                 If hh > 1 Then
                 wb.Sheets(G).Range("a" & bth + 1).Resize(hh - bw - bth, lh).Copy .Cells(.Range("a65536").End(xlUp).Row + n, 2)
                 .Range(.Cells(.Range("a65535").End(xlUp).Row + 1, 1), .Cells(.Range("b65535").End(xlUp).Row, 1)) = MyName & "-" & tqgzb
                 End If
                 n = (n + 1) ^ 0
                 End If
                Next
                wb.Close False
            End With
        End If

  End If
Next
    ActiveSheet.Name = "合并结果"
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    msgbox"合并完毕!"
End Sub
Sub Zdir(P)
Set Fso = CreateObject("scripting.filesystemobject")
For Each f In Fso.GetFolder(P).Files
If f Like "*.xls*" Then
    s = s + 1
ReDim Preserve arr(1 To s)
    arr(s) = f
    End If
Next
For Each m In Fso.GetFolder(P).SubFolders
    Zdir m
Next
End Sub

TA的精华主题

TA的得分主题

发表于 2018-10-18 11:16 | 显示全部楼层
  1. Sub 导入文件()   '从当前文件夹下不同表导入数据
  2.     Dim Filename$, fn$
  3.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
  4.     Do While Filename <> ""
  5.         If Filename <> ThisWorkbook.Name Then
  6.             fn = ThisWorkbook.Path & "" & Filename
  7.             Sql = Sql & " union all select * from [" & fn & "].[sheet1$a3:d]"
  8.         End If
  9.         Filename = Dir
  10.     Loop
  11.    
  12.     Set cnn = CreateObject("ADODB.Connection")
  13.     cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0';data source=" & ThisWorkbook.FullName
  14.     [a4].CopyFromRecordset cnn.Execute(Mid(Sql, 12))
  15.     cnn.Close: Set cnn = Nothing
  16. End Sub
复制代码

新建文件夹.rar

13.25 KB, 下载次数: 31

TA的精华主题

TA的得分主题

发表于 2018-10-18 11:23 | 显示全部楼层
Sub ADO加数组法()
    Dim cnn As Object, rs As Object, SQL$, MyPath$, MyFile$, s$, t$
    Dim arr, brr(1 To 65530, 0 To 3), d As Object, i&, j&, m&
    Set d = CreateObject("scripting.dictionary")
    MyPath = ThisWorkbook.Path & "/"
    MyFile = Dir(MyPath & "*.xls")
    Do While MyFile <> ""
        If InStr(MyFile, ThisWorkbook.Name) = 0 Then
            Set cnn = CreateObject("ADODB.Connection")
            cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & MyPath & MyFile
            Set rs = cnn.OpenSchema(20)
            Do Until rs.EOF
                If rs.Fields("TABLE_TYPE") = "TABLE" Then
                    s = Replace(rs("TABLE_NAME").Value, "'", "")
                    If Right(s, 1) = "$" Then
                    If InStr(s, "Sheet1") Then
                        SQL = "select * from [" & s & "A3:D] where 部门 is not null"
                        arr = cnn.Execute(SQL).GetRows
                        For i = 0 To UBound(arr, 2)
                                m = m + 1
                                For j = 0 To 3
                                    brr(m, j) = arr(j, i)
                                Next
                        Next
                    End If
                    End If
                End If
                rs.MoveNext
            Loop
        End If
        MyFile = Dir()
    Loop
    ActiveSheet.UsedRange.Offset(3).ClearContents
    [a4].Resize(m, 4) = brr
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
End Sub

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-10-18 11:57 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-10-18 11:59 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
一语清风 发表于 2018-10-18 11:57
试了几次,要报错,我用的是2003

2003的连接改成如下cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties='excel 8.0';data source=" & ThisWorkbook.FullName

TA的精华主题

TA的得分主题

发表于 2018-10-18 12:29 | 显示全部楼层
你们的都是代码 不是工具 对于不懂代码意义的人来说 只能又一次 表格一变就马上完蛋

TA的精华主题

TA的得分主题

发表于 2019-6-12 19:33 | 显示全部楼层
cjc209 发表于 2018-10-18 11:16
Dim arr(), s&
Sub 多簿多表合并为一表()
   Dim MyPath, MyName, AWbName

图1 实现图2  然后要自己更新
QQ图片20190612191005.png
Snipaste_2019-06-12_17-50-23.png
QQ图片20190612191005.png

2017年进项发票VBAabc123.zip

48.89 KB, 下载次数: 16

TA的精华主题

TA的得分主题

发表于 2019-6-12 20:50 | 显示全部楼层
shijin889 发表于 2019-6-12 19:33
图1 实现图2  然后要自己更新

自己开帖,不要寄生在老帖后面!

TA的精华主题

TA的得分主题

发表于 2019-6-12 20:53 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

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

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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