AW: Tab suchen
12.03.2010 18:37:44
Josef
Hallo Volker,
ja, das geht.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub Test()
Dim a As Variant, lngIndex As Long
Dim blnExist As Boolean
Dim strTab As String, strFile As String
strTab = "Tabelle1" 'Tabellenname
strFile = "E:\Forum\68515.xlsm" 'Dateiname
a = GetSheetNames(strFile)
If IsArray(a) Then
For lngIndex = 0 To UBound(a)
If a(lngIndex) = strTab Then
blnExist = True
End If
Next
End If
MsgBox "Das Blatt '" & strTab & "' gibt es" & IIf(blnExist, "!", " nicht!")
End Sub
Private Function GetSheetNames(ByVal File As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
Dim objADO_Connection As Object, objADO_Catalog As Object, objADO_Tables As _
Object
Dim lngIndex As Long, intLength As Integer, intPos As Integer, intStart As _
Integer
Dim strConString As String, strTable As String
Dim varTmp() As Variant
If Dir(File, vbNormal) = "" Then Exit Function
If Mid(File, InStrRev(File, ".") + 1) = "xls" Then
strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Extended Properties=Excel 8.0;" & _
"Data Source=" & File & ";"
ElseIf Mid(File, InStrRev(File, ".") + 1) Like "xls?" Then
strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Extended Properties=""Excel 12.0;HDR=YES"";" & _
"Data Source=" & File & ";"
Else
Exit Function
End If
Set objADO_Connection = CreateObject("ADODB.Connection")
objADO_Connection.Open strConString
Set objADO_Catalog = CreateObject("ADOX.Catalog")
Set objADO_Catalog.ActiveConnection = objADO_Connection
For Each objADO_Tables In objADO_Catalog.Tables
strTable = objADO_Tables.Name
intLength = Len(strTable)
intPos = 0
intStart = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(strTable, 1) = "'" And Right(strTable, 1) = "'" Then
intPos = 1
intStart = 2
End If
'Worksheet names always end in the "$" character
If Mid$(strTable, intLength - intPos, 1) = "$" Then
Redim Preserve varTmp(lngIndex)
varTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + _
intPos))
lngIndex = lngIndex + 1
End If
Next objADO_Tables
If lngIndex > 0 Then GetSheetNames = varTmp
objADO_Connection.Close
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing
End Function
Gruß Sepp