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

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

本帖最后由 zhaogang1960 于 2015-12-21 17:54 编辑

高峰3424 发表于 2015-12-21 17:36
好了重新修改了，帮忙再看看，谢谢

Sub 常规法()
Dim Fso As Object, File As Object, m&, arr(), c As Range, sh As Worksheet, sht As Worksheet
Application.ScreenUpdating = False '屏蔽屏幕刷新
Set Fso = CreateObject("Scripting.FileSystemObject") '创建Fso对象
ReDim arr(1 To Fso.GetFolder(ThisWorkbook.Path).Files.Count - 1, 1 To 3) '重新定义数组，行数为文件数-1，列数3
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("采购及保管费", , , xlPart) '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
            Set sht = .Sheets("表二") '查找"表二工作表
            If Not sht Is Nothing Then '查到
                  Set c = sht.[b:b].Find("主要材料费", , xlValues, xlPart) '表二B列查找"主要材料费"
                  If Not c Is Nothing Then '查到
                     arr(m, 3) = Val(c.Offset(, 2).Value) 'd列的值
                  Else
                     arr(m, 3) = 0 '没有查到0
                  End If
                  Set sht = Nothing
            Else
                  arr(m, 3) = 0 '没有查到表二工作表0
            End If
            .Close 0
         End With
      End If
Next
ActiveSheet.UsedRange.Offset(1).ClearContents '删除原数据
Range("A2").Resize(m, 3) = arr '写数据
Set Fso = Nothing
Application.ScreenUpdating = False
End Sub

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

请测试附件

案例.rar (137.2 KB, 下载次数: 83)

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

zhaogang1960 发表于 2015-12-21 17:55
请测试附件

谢谢，可以解决问题，在我这个代码上面有办法直接加判定不

Sub tt()
Dim ws As Workbook, sht As Worksheet, rng As Range, rnd As Range
Dim path$, myname$, d, k&
Application.ScreenUpdating = False
path = ThisWorkbook.path & ""
d = Dir(path & "*.xls")
k = 1
With ActiveSheet
[a2:z5000].ClearContents
Do While d <> ""
If d <> ThisWorkbook.Name Then
k = k + 1
Set ws = Workbooks.Open(path & d)
.Cells(k, 3) = Replace(ws.Name, ".xls", "")
Set rng = ws.Sheets("表一").Range("b:b").Find(What:="*合计*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 5) = rng.Offset(0, 7)
Set rng = ws.Sheets("表二").Range("b:b").Find(What:="*主要材料费*", lookat:=xlPart)
Set rnd = ws.Sheets("表四（乙供材）").Range("b:b").Find(What:="*总计*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 6) = rng.Offset(0, 2) - rnd.Offset(0, 5)
Set rng = ws.Sheets("表四（乙供材）").Range("b:b").Find(What:="*总计*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 7) = rng.Offset(0, 5)
Set rng = ws.Sheets("表五甲").Range("b:b").Find(What:="*安全生产费*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 9) = rng.Offset(0, 4)
Set rng = ws.Sheets("表五甲").Range("b:b").Find(What:="*建设用地及综合赔补费*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 10) = rng.Offset(0, 4)
Set rng = ws.Sheets("表二").Range("b:b").Find(What:="*建筑安装工程费*", lookat:=xlPart)
Set rnd = ws.Sheets("表二").Range("b:b").Find(What:="*主要材料费*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 8) = rng.Offset(0, 2) - rnd.Offset(0, 2)
Set rng = ws.Sheets("表五甲").Range("b:b").Find(What:="*勘察设计费*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 11) = rng.Offset(0, 4)
Set rng = ws.Sheets("表五甲").Range("b:b").Find(What:="*建设工程监理费*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 12) = rng.Offset(0, 4)
Set rng = ws.Sheets("表一").Range("b:b").Find(What:="*合计*", lookat:=xlPart)
If Not rng Is Nothing Then .Cells(k, 25) = rng.Offset(0, 2)
ws.Close False
End If
d = Dir
Loop
End With
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2015-12-21 18:54

本帖最后由 zhaogang1960 于 2015-12-21 18:58 编辑

写了一个判断工作表是否存在自定义函数，你可以套用：
Sub 常规法()
Dim p$, f$, m&, arr(1 To 10000, 1 To 3), c As Range, wb As Workbook
Application.ScreenUpdating = False '屏蔽屏幕刷新
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls")
Do While f <> ""
      If f <> ThisWorkbook.Name Then
         m = m + 1 '加一行
         arr(m, 1) = Replace(f, ".xlsx", "") '第一列为文件名
         Set wb = GetObject(p & f) '打开该工作簿
         If bisWorksheet(wb, "表四甲(主材表)") Then '判断"表四甲(主材表)"工作表已存在
            Set c = wb.Sheets("表四甲(主材表)").[b:b].Find("采购及保管费", , , xlPart) 'B列查找"采购及保管费"
            If Not c Is Nothing Then '查到
                  arr(m, 2) = Val(c.Offset(, 6).Value) 'h列的值
            Else
                  arr(m, 2) = 0 '没有查到0
            End If
         Else
            arr(m, 2) = 0 '没有查到"表四甲(主材表)工作表0
         End If
         If bisWorksheet(wb, "表二") Then  '判断"表二"工作表已存在
            Set c = wb.Sheets("表二").[b:b].Find("主要材料费", , xlValues, xlPart) '表二B列查找"主要材料费"
            If Not c Is Nothing Then '查到
                  arr(m, 3) = Val(c.Offset(, 2).Value) 'd列的值
            Else
                  arr(m, 3) = 0 '没有查到0
            End If
         Else
            arr(m, 3) = 0 '没有查到表二工作表0
         End If
         wb.Close 0
      End If
      f = Dir
Loop
ActiveSheet.UsedRange.Offset(1).ClearContents '删除原数据
Range("A2").Resize(m, 3) = arr '写数据

Application.ScreenUpdating = False
End Sub

Public Function bisWorksheet(wb As Workbook, s$) As Boolean '判断工作表存在函数
Dim sh As Worksheet
On Error Resume Next
Set sh = wb.Sheets(s)
If Not sh Is Nothing Then bisWorksheet = True
End Function

zhaogang1960 · 发表于 2015-12-21 18:55

本帖最后由 zhaogang1960 于 2015-12-21 18:59 编辑

请参考附件

案例.rar (136.72 KB, 下载次数: 104)

LMY123 · 发表于 2018-8-23 16:41

If Err.Number = 0 Then

补充内容 (2019-1-1 16:30):
同夹_多薄_指定表_单条件_模糊查询_常规法，ADO法，已入代码宝库。

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

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

评分