分表数据复制到汇总表

一语清风

1、同一文件夹，分表数据复制到汇总表
2、不打开分表

cjc209

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

grf1973

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

复制代码

LMY123

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

一语清风

grf1973 发表于 2018-10-18 11:16

试了几次，要报错，我用的是2003

xd3210

一语清风 发表于 2018-10-18 11:57
试了几次，要报错，我用的是2003

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

cjc209

你们的都是代码 不是工具 对于不懂代码意义的人来说 只能又一次 表格一变就马上完蛋

shijin889

cjc209 发表于 2018-10-18 11:16
Dim arr(), s&
Sub 多簿多表合并为一表()
   Dim MyPath, MyName, AWbName

图1 实现图2  然后要自己更新

lsc900707

shijin889 发表于 2019-6-12 19:33
图1 实现图2  然后要自己更新

自己开帖，不要寄生在老帖后面！

shijin889

lsc900707 发表于 2019-6-12 20:50
自己开帖，不要寄生在老帖后面！

好的  马上改