' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub WorkbookKlientOpen()
Dim WB As Workbook
Dim strFile As String, strPath As String, strSheet As String
Dim vntSheets As Variant
On Error GoTo ErrExit
strSheet = Format(Range("E7"), "0000")
strPath = "C:\Versuche\"
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFile = Dir(strPath & "*.xls*", vbNormal)
Do While strFile <> ""
vntSheets = GetSheetNames(strPath & strFile)
If IsNumeric(Application.Match(strSheet, vntSheets, 0)) Then
Set WB = Workbooks.Open(strPath & strFile)
WB.Worksheets(strSheet).Select
Exit Sub
End If
strFile = Dir
Loop
ErrExit:
MsgBox "¡Proyecto no existe!"
End Sub
Private Function GetSheetNames(ByVal FileName As String) As Variant
'original by Bob Phillips, adapted by j.ehrensberger
Dim objADO As Object, objCAT As Object, objTAB As Object
Dim lngI As Long, intL As Integer, intP As Integer, intS As Integer
Dim strCon As String, strTab As String
Dim vntTmp() As Variant
If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
"Data Source=" & FileName & ";"
ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR=YES"";" _
& "Data Source=" & FileName & ";"
Else
Exit Function
End If
Set objADO = CreateObject("ADODB.Connection")
objADO.Open strCon
Set objCAT = CreateObject("ADOX.Catalog")
Set objCAT.ActiveConnection = objADO
For Each objTAB In objCAT.Tables
strTab = objTAB.Name
intL = Len(strTab)
intP = 0
intS = 1
'Worksheet name with embedded spaces enclosed by single quotes
If Left(strTab, 1) = "'" And Right(strTab, 1) = "'" Then
intP = 1
intS = 2
End If
'Worksheet names always end in the "$" character
If Mid$(strTab, intL - intP, 1) = "$" Then
Redim Preserve vntTmp(lngI)
vntTmp(lngI) = Mid$(strTab, intS, intL - (intS + intP))
lngI = lngI + 1
End If
Next objTAB
If lngI > 0 Then GetSheetNames = vntTmp
objADO.Close
Set objCAT = Nothing
Set objADO = Nothing
End Function