提取文件夹下所有工作薄中对应位置的值（需判定）

高峰3424 · 发表于 2015-12-21 14:50

由于用ExceL公式做出来的提取值必须打开工作薄，当工作薄太多的时候实在麻烦，现求助VBA高手帮忙。
现在想实现，在汇总表里做程序，自动提取文件名（不带后辍）放到A列，然后在B列提取出对应文件里“表四甲(主材表)”中B列包含“采购及保管费”所对应的H列的值光缆工程一和光缆工程二是正常工程，要求正常列出值
光缆工程三中“表四甲(主材表)”没有“采购及保管费”，要求有A列出文件名（不带后辍），H列显示空或者0
光缆工程四中没有“表四甲(主材表)”这个工作表，要求有A列出文件名（不带后辍），H列显示空或者0
也就是正常项目列出要求的值，如果文件中找不到要查找的东西，则显示空或者0
谢谢大家了！最好能给代码后面备注其作用，由于刚学VBA看不太懂

高峰3424 · 发表于 2015-12-21 16:35

高手在哪里呀，高手在哪里

zhaogang1960 · 发表于 2015-12-21 16:36

请参考：

Sub ADO法()
Dim Fso As Object, File As Object, cnn As Object, rs As Object, SQL$, m&, arr()
Set Fso = CreateObject("Scripting.FileSystemObject")
ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count - 1, 1 To 2)
On Error Resume Next
For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
If File.Name Like "*.xlsx" Then
m = m + 1
arr(m, 1) = Replace(File.Name, ".xlsx", "")
Set cnn = CreateObject("adodb.connection")
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='excel 12.0;hdr=no';data source=" & File
SQL = "select f7 from [表四甲(主材表)$B7:H] where f1 like '%采购及保管费%'"
Set rs = CreateObject("adodb.recordset")
rs.Open SQL, cnn, 1, 3
If Err.Number = 0 Then
If Not rs.EOF Then
arr(m, 2) = rs.Fields(0)
Else
arr(m, 2) = 0
End If
Else
arr(m, 2) = 0
Err.Clear
End If
End If
Next
ActiveSheet.UsedRange.Offset(1).ClearContents
Range("A2").Resize(m, 2) = arr
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Set Fso = Nothing
End Sub

复制代码

zhaogang1960 · 发表于 2015-12-21 16:38

请测试附件

案例.rar (140.54 KB, 下载次数: 68)

高峰3424 · 发表于 2015-12-21 16:57

zhaogang1960 发表于 2015-12-21 16:38
请测试附件

如果我想再增加提取数据怎么弄呢，这个没注释，看不明白
比如我想在刚才的基础上，现在增加提取表二B列等于”主要材料费"所对应的D列的值，然后放到汇总表C列
谢谢啦

zhaogang1960 · 发表于 2015-12-21 17:04

高峰3424 发表于 2015-12-21 16:57
如果我想再增加提取数据怎么弄呢，这个没注释，看不明白
比如我想在刚才的基础上，现在增加提取表二B列 ...

ADO法不太好理解，下面常规法请参考：
Sub 常规法()
Dim Fso As Object, File As Object, m&, arr(), c As Range, sh As Worksheet
Application.ScreenUpdating = False '屏蔽屏幕刷新
Set Fso = CreateObject("Scripting.FileSystemObject") '创建Fso对象
ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count - 1, 1 To 2) '重新定义数组，行数为文件数-1，列数2
On Error Resume Next '忽略错误提示
For Each File In Fso.GetFolder(ThisWorkbook.Path).Files '逐个文件
      If File.Name Like "*.xlsx" Then '文件类型为xlsx工作簿
         m = m + 1 '加一行
         arr(m, 1) = Replace(File.Name, ".xlsx", "") '第一列为文件名
         With GetObject(File) '打开该工作簿
            Set sh = .Sheets("表四甲(主材表)") '查找"表四甲(主材表)工作表
            If Not sh Is Nothing Then '查到
                  Set c = sh.[b:b].Find("采购及保管费", , , 2) 'B列查找"采购及保管费"
                  If Not c Is Nothing Then '查到
                     arr(m, 2) = Val(c.Offset(, 6).Value) 'h列的值
                  Else
                     arr(m, 2) = 0 '没有查到0
                  End If
                  Set sh = Nothing
            Else
                  arr(m, 2) = 0 '没有查到"表四甲(主材表)工作表0
            End If
            .Close 0
         End With
      End If
Next
ActiveSheet.UsedRange.Offset(1).ClearContents '删除原数据
Range("A2").Resize(m, 2) = arr '写数据
Set Fso = Nothing
Application.ScreenUpdating = False
End Sub

zhaogang1960 · 发表于 2015-12-21 17:06

附件………………………………

常规法.rar (141.28 KB, 下载次数: 54)

高峰3424 · 发表于 2015-12-21 17:17

zhaogang1960 发表于 2015-12-21 17:06
附件………………………………

呀，还是不知道如果想增加查找的值怎么改，其实我是想查找好几个对应的值分别放到2、3、4列

zhaogang1960 · 发表于 2015-12-21 17:26

高峰3424 发表于 2015-12-21 17:17
呀，还是不知道如果想增加查找的值怎么改，其实我是想查找好几个对应的值分别放到2、3、4列

如果你不会修改，还是把附件发上来吧

高峰3424 · 发表于 2015-12-21 17:36

zhaogang1960 发表于 2015-12-21 17:26
如果你不会修改，还是把附件发上来吧

好了重新修改了，帮忙再看看，谢谢

		自动登录	找回密码
密码			免费注册

[求助] 提取文件夹下所有工作薄中对应位置的值（需判定）