Sheet aus einer anderen Mappe heraus öffnen

Sub WorkbookKlientOpen() Dim WB As Workbook Dim strDatei As String Dim strSheet As String On Error GoTo fehler strDatei = Dir("C:\Versuche\*" & Format(Range("E6"), "0000") & "*.xlsm") strSheet = Format(Range("E7"), "0000") If strDatei "" Then Set WB = Workbooks.Open("C:\Versuche\" & strDatei) WB.Worksheets(strSheet).Select End If Exit Sub fehler: MsgBox "¡Proyecto no existe!" End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Luna,
ungetestet!

' **********************************************************************
' 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

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Sheet aus einer anderen Mappe heraus öffnen

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

65 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Sheet aus einer anderen Mappe heraus öffnen

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

65 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread