怎样让多个同格式的EXCEL表格中指定的几个单元格内容汇总到一个汇总表中

wxr1245

怎样让几十个同格式的EXCEL表格中特定的几个单元格内容汇总到一个汇总表中，像附件中列出的，其中黄颜色部分的单元格内容汇总到汇总表中，一张一行。

求大神帮忙！

zhaogang1960

ADO法速度快，请参考：
Sub ADO法()
    Dim Fso As Object, File As Object, cnn As Object, rs  As Object, SQL$, n&, arr, brr(), i&
    Application.ScreenUpdating = False
    arr = [{"AE13:AE13","CC20:CC20","DK20:DK20","CC22:CC22","N32:N32","DA32:DA32"}]
    Set Fso = CreateObject("Scripting.FileSystemObject")
    ReDim brr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count, 1 To 6)
    Set cnn = CreateObject("adodb.connection")
    For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
        If File.Name Like "*.xlsx" Then
            n = n + 1
            If n = 1 Then cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 12.0;data source=" & File
            For i = 1 To 6
                SQL = "select f1 from [Excel 12.0;hdr=no;Database=" & File & ";].[DeliveryOrder(Page 1)$" & arr(i) & "]"
                Set rs = cnn.Execute(SQL)
                brr(n, i) = rs.Fields(0)
            Next
        End If
    Next
    ActiveSheet.UsedRange.Offset(1).ClearContents
    Range("A2").Resize(n, 6) = brr
    rs.Close
    cnn.Close
    Set rs = Nothing
    Set cnn = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

zhaogang1960

请测试附件
x.rar (127.66 KB, 下载次数: 459)

2016-2-3 16:38 上传

点击文件名下载附件

龙城飞将III

1. Private Sub CommandButton1_Click()
   
2.     Dim wbWb As Workbook
   
3.     Dim strFileName As String
   
4.     Dim strFilePath As String
   
5.     Dim i As Long
   
6.     ReDim arrInfo(1 To 6, 1 To 1)
   
7.    
   
8.     On Error Resume Next
   
9.     Application.ScreenUpdating = False
   
10.     Application.DisplayAlerts = False
    
11.    
    
12.     strFileName = Dir(ThisWorkbook.Path & "\*.xls*")
    
13.     strFilePath = ThisWorkbook.Path & "" & strFileName
    
14.     Do
    
15.         If strFileName <> ThisWorkbook.Name Then
    
16.             Set wbWb = Workbooks.Open(strFilePath)
    
17.             i = i + 1
    
18.             ReDim Preserve arrInfo(1 To 6, 1 To i)
    
19.             With wbWb.Sheets(1)
    
20.                 arrInfo(1, i) = .Range("AE13")
    
21.                 arrInfo(2, i) = .Range("CC20")
    
22.                 arrInfo(3, i) = .Range("DK20")
    
23.                 arrInfo(4, i) = .Range("CC22")
    
24.                 arrInfo(5, i) = .Range("N32")
    
25.                 arrInfo(6, i) = .Range("DA32")
    
26.             End With
    
27.             wbWb.Close
    
28.             Set wbWb = Nothing
    
29.         End If
    
30.         strFileName = Dir
    
31.         strFilePath = ThisWorkbook.Path & "" & strFileName
    
32.     Loop Until strFileName = ""
    
33.    
    
34.     Range("a2").Resize(UBound(arrInfo, 2), 6) = Application.WorksheetFunction.Transpose(arrInfo)
    
35.     Application.ScreenUpdating = True
    
36.     Application.DisplayAlerts = True
    
37. End Sub
    

复制代码

wxr1245

非常感谢！！使用起来相当方便。

LMY123

合并多工作薄不连续单元格

补充内容 (2019-1-1 11:55):
同夹_多薄_指定表_合并成一薄一表_不连续单元格_ADO法,已入库。

jjmysjg

龙城飞将III 发表于 2016-2-3 17:06

我这冯X的表没有提取出来。
我这错在哪了

opiona

http://club.excelhome.net/thread-1409141-1-1.html

aecn

zhaogang1960 发表于 2016-2-3 16:38
请测试附件

要汇总指定子文件夹请问代码要怎么修改？