多个excel文件根据条件提取条目到新文件

uda1981

各位老师好：                   如附件,有多个excel文件根据条件提取条目到新文件，
      红圈内容非空的单元格对应的绿圈的值提取到新文件。并在每个条目第一行填上工程名称。     希望老师帮忙解答,感谢~

uda1981

Sub 按钮2_Click()
Updating = False
    Set cnn = CreateObject("adodb.connection")
    [a2:l65536].ClearContents
    h = 2
    f = Dir(ThisWorkbook.Path & "\" & "*.xls?")
    Do While f > ""
        If f <> ThisWorkbook.Name Then
            cnn.Open "provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=yes';data source=" & ThisWorkbook.Path & "\" & f
            Sql = "select * from [省配送甲供$c6:g] where 实用量 is not null"               
            Cells(h, 1).CopyFromRecordset cnn.Execute(Sql)
            h = Cells(Rows.Count, 1).End(xlUp).Row + 1   
            cnn.Close
        End If
        f = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
抄了一段，后面就不会了。。只实现了一小部分功能……

LMY123

uda1981 发表于 2018-8-26 09:55
Sub 按钮2_Click()
Updating = False
    Set cnn = CreateObject("adodb.connection")

1. 'http://club.excelhome.net/thread-1429224-1-1.html
   
2. Sub 第一列加入薄名参考()
   
3. Updating = False
   
4.     Set cnn = CreateObject("adodb.connection")
   
5.     [a2:l65536].ClearContents
   
6.     h = 2
   
7.     f = Dir(ThisWorkbook.Path & "" & "*.xls?")
   
8.     Do While f > ""
   
9.         If f <> ThisWorkbook.Name Then
   
10.             cnn.Open "provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=yes';data source=" & ThisWorkbook.Path & "" & f
    
11.             Sql = "select '" & Split(Split(f, "-")(1), ".")(0) & "',* from [省配送甲供$c6:g] where 实用量 is not null"
    
12.             Cells(h, 1).CopyFromRecordset cnn.Execute(Sql)
    
13.             h = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
14.             cnn.Close
    
15.         End If
    
16.         f = Dir
    
17.     Loop
    
18.     Application.ScreenUpdating = True
    
19. End Sub

复制代码

uda1981

LMY123 发表于 2018-8-26 10:23

非常感谢，学习了。

vanyear

多谢各位老师，好好学习

jjmysjg

LMY123 发表于 2018-8-26 10:23

Cells(h, 1).CopyFromRecordset cnn.Execute(Sql)
发黄，

LMY123

导入汇总.rar (1.95 MB, 下载次数: 39)

2018-8-28 08:50 上传

点击文件名下载附件

uda1981

LMY123 发表于 2018-8-28 08:50

太感谢了，一个星期的工作量，压缩到一个小时就完成了，省下的时学习vba。XD