如何判断多工作簿是否存在指定工作表，返回判断结果

xyd617

1、"TT-汇总"工作簿 “判断”工作表A列显示遍历当期文件夹所有工作簿名称

2、判断每个工作簿是否存在指定工作表名称“data”,有返回“存在”B列，无返回“不存在”在B列

lsc900707

1. Sub test()
   
2.     Dim arr(1 To 1000, 1 To 2)
   
3.     Application.ScreenUpdating = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.     Set ff = fso.getfolder(ThisWorkbook.Path)
   
6.     For Each f In ff.Files
   
7.         If f.Name <> ThisWorkbook.Name Then
   
8.             m = m + 1
   
9.             arr(m, 1) = Split(f.Name, ".")(0)
   
10.             Set wb = Workbooks.Open(f)
    
11.             For Each sht In wb.Sheets
    
12.                 If InStr(sht.Name, "data") Then
    
13.                     arr(m, 2) = "存在"
    
14.                 Else
    
15.                     arr(m, 2) = "不存在"
    
16.                 End If
    
17.             Next
    
18.             ActiveWorkbook.Close False
    
19.         End If
    
20.     Next
    
21.     [a2].CurrentRegion.Offset(1).ClearContents
    
22.     [a3].Resize(m, 2) = arr
    
23.     Application.ScreenUpdating = True
    
24. End Sub
    

复制代码

xyd617

lsc900707 发表于 2018-7-31 10:19

显示 无法打开汇总工作簿

lsc900707

xyd617 发表于 2018-7-31 10:42
显示 无法打开汇总工作簿

你是不是装的64位office2016呀？

xyd617

lsc900707 发表于 2018-7-31 10:52
你是不是装的64位office2016呀？

是32位的OFFICE 2016

这个是昵称吗

xyd617 发表于 2018-7-31 11:41
是32位的OFFICE 2016

我运行没问题啊！你是不是改了啥不该改的！

xiangbaoan

Sub test()
Dim sh As Worksheet, ar(1 To 888, 1 To 2), f, k%, msg$, nm$
Application.ScreenUpdating = False
For Each f In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).Files
    If f.Name <> ThisWorkbook.Name And InStr(f.Name, ".xls") Then
        k = k + 1
        With GetObject(f)
            nm = Split(.Name, ".")(0)
            Err.Clear
            On Error Resume Next
            Set sh = .Sheets("data")
            msg = IIf(Err.Number <> 0, "不存在", "存在")
            .Close 0
        End With
        ar(k, 1) = nm: ar(k, 2) = msg
    End If
Next
If k Then ThisWorkbook.Sheets("判断").[a3].Resize(k, 2) = ar
Application.ScreenUpdating = True
End Sub

xyd617

lsc900707 发表于 2018-7-31 10:52
你是不是装的64位office2016呀？

返回到 set wb = workbooks.open(f)  这里，显示找不到 放代码的  XLSM工作簿文件。

lsc900707

xyd617 发表于 2018-7-31 11:57
返回到 set wb = workbooks.open(f)  这里，显示找不到 放代码的  XLSM工作簿文件。

上一帖大神有回复你的文件夹有隐藏的文件，看看是不是这个原因。
附件测试代码是没有问题的。

xiangbaoan

在当前文件夹下新建一个工作簿，运行下面的语句后，再试一下：

1. Sub del()
   
2. Application.ScreenUpdating = False
   
3. Dim fso, f
   
4. Set fso = CreateObject("Scripting.FileSystemObject")
   
5. For Each f In fso.GetFolder(ThisWorkbook.Path).Files
   
6.     If Left(f.Name, 2) = "~$" And InStr(f.Name, ".xls") Then fso.Deletefile f, 1
   
7. Next
   
8. Set fso = Nothing
   
9. Application.ScreenUpdating = True
   
10. End Sub

复制代码