【求看】用VBA按钮按要求提取合并数据怎么做！！！！！

上岸人鱼

data文件夹中03#、04#、05#表的bin列为1时全选
datas文件夹中03#、04#、05#表的bin列不分好坏全选
全部合并到同一张表分别为new.xls和news.xls 提取合并数据.rar (231.18 KB, 下载次数: 9)

2016-3-10 14:55 上传

点击文件名下载附件

zhaogang1960

Sub datas()
    Dim Fso As Object, File As Object, cnn As Object, SQL$, n&, r&
    Application.ScreenUpdating = False
    Range("A4:J65536").ClearContents
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set cnn = CreateObject("adodb.connection")
    For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
        If File.Name Like "*.xls" And File.Name <> ThisWorkbook.Name Then
            n = n + 1
            If n = 1 Then cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & File
            SQL = "select f2,f3,f4,f5,f6,f7,f8,f9,f10 from [Excel 8.0;hdr=no;Database=" & File & ";].[Data$B25:K]"
            r = [b65536].End(xlUp).Row + 1
            Cells(r, 1) = Replace(File.Name, ".xls", "")
            Range("b" & r).CopyFromRecordset cnn.Execute(SQL)
        End If
    Next
    cnn.Close
    Set cnn = Nothing
    Set File = Nothing
    Set Fso = Nothing
    Application.ScreenUpdating = True
End Sub

zhaogang1960

请测试附件
提取合并数据.rar (249.09 KB, 下载次数: 43)

2016-3-10 15:33 上传

点击文件名下载附件

上岸人鱼

zhaogang1960 发表于 2016-3-10 15:33
请测试附件

太好用了，很棒！！！！

LMY123

1. Sub ADO多薄首表合并成一薄一表_并写入薄名()
   
2.     Dim Fso As Object, File As Object, cnn As Object, SQL$, n&, r&
   
3.     Application.ScreenUpdating = False
   
4.     Range("A4:J65536").ClearContents
   
5.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set cnn = CreateObject("adodb.connection")
   
7.     For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
   
8.         If File.Name Like "*.xls" And File.Name <> ThisWorkbook.Name Then
   
9.             n = n + 1
   
10.             If n = 1 Then cnn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & File
    
11.             SQL = "select f2,f3,f4,f5,f6,f7,f8,f9,f10 from [Excel 8.0;hdr=no;Database=" & File & ";].[$B25:K]"
    
12.             r = [b65536].End(xlUp).Row + 1
    
13.             Cells(r, 1) = Replace(File.Name, ".xls", "")
    
14.             Range("b" & r).CopyFromRecordset cnn.Execute(SQL)
    
15.         End If
    
16.     Next
    
17.     cnn.Close
    
18.     Set cnn = Nothing
    
19.     Set File = Nothing
    
20.     Set Fso = Nothing
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码