如何检查一个未打开的工作簿是否存在某张表？

cloudshare · 发表于 2014-4-9 12:01

各位大侠：
请教一下，检查未打开的工作簿中是否存在某张表名的工作表是否存在的代码？
思考了很久也没有办法，现向各位求助了，感谢！

office8424 · 发表于 2014-4-9 12:15

http://club.excelhome.net/thread-228420-1-1.html
我只能帮你到这里了

zhaogang1960 · 发表于 2014-4-9 12:33

使用ADO：

Sub determineWorkSheetExist()
Dim cnn As Object, MyWorkSheet As String
MyWorkSheet = "在册员工$"
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.Path & "\Book1.xlsx"
If cnn.OpenSchema(20, Array(Empty, Empty, MyWorkSheet, Empty)).EOF Then
MsgBox "“" & MyWorkSheet & "”表" & "不存在"
Else
MsgBox "“" & MyWorkSheet & "” 表" & "已存在"
End If
End Sub

复制代码

zhaogang1960 · 发表于 2014-4-9 12:41

或用自定义函数：

Public Function bWorkSheetExist(MyPath As String, MyWorkSheet As String) As Boolean
Dim cnn As Object
If Dir(MyPath) <> "" Then
If Right$(MyWorkSheet, 1) <> "$" Then MyWorkSheet = MyWorkSheet & "$"
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & MyPath
bWorkSheetExist = Not cnn.OpenSchema(20, Array(Empty, Empty, MyWorkSheet, Empty)).EOF
End If
End Function

复制代码

Sub test() '测试效果
Dim MyPath As String, MyWorkSheet As String
MyPath = ThisWorkbook.Path & "\Book1.xlsx"
MyWorkSheet = "在册员工$"
If bWorkSheetExist(MyPath, MyWorkSheet) Then
MsgBox "“" & MyWorkSheet & "” 表" & "已存在"
Else
MsgBox "“" & MyWorkSheet & "”表" & "不存在"
End If
End Sub

复制代码

zhaogang1960 · 发表于 2014-4-9 12:43

请参考下面附件

如何检查一个未打开的工作簿是否存在某张表.rar (23.77 KB, 下载次数: 67)

cloudshare · 发表于 2014-4-9 13:50

本帖最后由 cloudshare 于 2014-4-9 13:55 编辑

zhaogang1960 发表于 2014-4-9 12:43
请参考下面附件

Private Sub CommandButton1_Click()
'AutoScreenUpdate False
'AutoCalculation False
Sheets("预算总成本").Range("a2:e1048576").ClearContents
Path = ThisWorkbook.Path & "\"
f = Dir(Path & "*.xls")
While f > ""
      If f <> ThisWorkbook.Name Then
      Dim cnn As Object, MyWorkSheet As String
      MyWorkSheet = "预算成本总表$"
      Set cnn = CreateObject("ADODB.Connection")
      cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Path & f
         If cnn.OpenSchema(20, Array(Empty, Empty, MyWorkSheet, Empty)).EOF Then
            GoTo a
         Else
            ThisWorkbook.Sheets("预算总成本").Cells(ThisWorkbook.Sheets("预算总成本").Cells(Rows.Count, 1).End(xlUp).Row + 1, 3) = GetValue(Path, f, "预算成本总表", "b2")
            ThisWorkbook.Sheets("预算总成本").Cells(ThisWorkbook.Sheets("预算总成本").Cells(Rows.Count, 1).End(xlUp).Row + 1, 4) = GetValue(Path, f, "预算成本总表", "d2")
            ThisWorkbook.Sheets("预算总成本").Cells(ThisWorkbook.Sheets("预算总成本").Cells(Rows.Count, 1).End(xlUp).Row + 1, 5) = GetValue(Path, f, "预算成本总表", "e28") - GetValue(Path, f, "预算成本总表", "e23") - GetValue(Path, f, "预算成本总表", "e24") - GetValue(Path, f, "预算成本总表", "e25") - GetValue(Path, f, "预算成本总表", "e26")
            If ThisWorkbook.Sheets("预算总成本").Cells(Rows.Count, 1).End(xlUp).Row = 1 Then
                  ThisWorkbook.Sheets("预算总成本").Cells(ThisWorkbook.Sheets("预算总成本").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = 1
            Else
                  ThisWorkbook.Sheets("预算总成本").Cells(ThisWorkbook.Sheets("预算总成本").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = ThisWorkbook.Sheets("预算总成本").Cells(ThisWorkbook.Sheets("预算总成本").Cells(Rows.Count, 1).End(xlUp).Row, 1).Value + 1
            End If
         End If
      End If
a:       f = Dir()
Wend

'AutoCalculation True
'AutoScreenUpdate True
End Sub
Sub rescreenupdate()
AutoScreenUpdate True
End Sub
Private Function GetValue(Path, File, Sheet, Ref)
' 从未打开的工作簿中获取数据
Dim arg As String
' 检查文件是否存在
' If Right(Path, 1) <> "\" Then Path = Path & "\"
' If Dir(Path & file) = "" Then
'       GetValue = "File Not Found"
'       Exit Function
' End If
' 建立参数
arg = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
   Range(Ref).Range("A1").Address(, , xlR1C1)
' 运行XLM宏
GetValue = ExecuteExcel4Macro(arg)                                     ------打开文件选择对话框
End Function

为何执行到函数部分 GetValue = ExecuteExcel4Macro(arg)  为何会弹出打开文件对话框，让选择一个文件？

zhaogang1960 · 发表于 2014-4-9 14:47

cloudshare 发表于 2014-4-9 13:50
Private Sub CommandButton1_Click()
'AutoScreenUpdate False
'AutoCalculation False

请上传附件，看看能否使用ADO取值

cloudshare · 发表于 2014-4-9 14:53

附件已经上传

cloudshare · 发表于 2014-4-9 15:13

zhaogang1960 发表于 2014-4-9 14:47
请上传附件，看看能否使用ADO取值

附件已经上传。

zhaogang1960 · 发表于 2014-4-9 15:46

cloudshare 发表于 2014-4-9 14:53
附件已经上传

Private Sub CommandButton1_Click()
Dim sh As Worksheet
Set sh = Sheets("预算总成本")
Range("a2:e1048576").ClearContents
Path = ThisWorkbook.Path & ""
f = Dir(Path & "*.xls*")
While f > ""
If f <> ThisWorkbook.Name Then
Dim cnn As Object, MyWorkSheet As String
MyWorkSheet = "预算成本总表$"
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Extended Properties='Excel 12.0;hdr=no';Data Source=" & Path & f
If Not cnn.OpenSchema(20, Array(Empty, Empty, MyWorkSheet, Empty)).EOF Then
lr = sh.Range("a1").CurrentRegion.Rows.Count + 1
sh.Cells(lr, 2) = Split(f, "_")(0)
sh.Cells(lr, 3) = cnn.Execute("select f1 from [预算成本总表$b2:b2]")(0)
sh.Cells(lr, 4) = cnn.Execute("select f1 from [预算成本总表$d2:d2]")(0)
sh.Cells(lr, 5) = cnn.Execute("select f1 from [预算成本总表$e28:e28]")(0)
End If
End If
f = Dir()
Wend
cnn.Close
Set cnn = Nothing
' 以下没有修改
Dim m, o, p, q As Range
Dim h1 As Integer
h1 = Sheets("预算总成本").Cells(Rows.Count, 1).End(xlUp).Row
For Each m In Worksheets("预算总成本").Range("b2:b" & h1)
If m = "" Then
Cells(m.Row, m.Column).Interior.ColorIndex = 3
End If
Next
For Each o In Worksheets("预算总成本").Range("c2:c" & h1)
If o = "" Then
Cells(o.Row, o.Column).Interior.ColorIndex = 3
End If
Next
For Each p In Worksheets("预算总成本").Range("d2:d" & h1)
If p = "" Then
Cells(p.Row, p.Column).Interior.ColorIndex = 3
End If
Next
For Each q In Worksheets("预算总成本").Range("e2:e" & h1)
If q = "" Then
Cells(q.Row, q.Column).Interior.ColorIndex = 3
End If
Next
'AutoCalculation True
'AutoScreenUpdate True
End Sub

复制代码

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

[求助] 如何检查一个未打开的工作簿是否存在某张表？