Tabellenblattnamen aus geschlossener Datei - Codealternativen gesucht

[ratrad]

Hallo liebe Experten,

ich möchte gerne die Tabellenblattnamen aus einer geschlossenen Excel-Datei auslesen. Dazu habe ich mir ein kleines Programm geschrieben, das diese Namen ausgehend von der aktiven Zelle in meinem geöffneten Excel-Arbeitsblatt untereinander wiedergibt. Der Code funktioniert. Leider sind meine Programmierkenntnisse bescheiden. Wie könnte man das Programm eleganter schreiben?

Code:

Option Explicit

Sub Blattnamenauslesen()
   'Programm zum Auslesen der Tabellenblattnamen
   'aus der geschlossenen Datei Datei.xls im Verzeichnis C:\Test
   Dim sFile As String
   Dim wb As Workbook
   Dim vbFeld(1 To 100) As Variant
   Dim i As Variant
   Dim ws As Worksheet
   Dim a As Integer
  
   sFile = "C:\Test\Datei.xls"
  
   i = 1
   Set wb = Workbooks.Open(sFile)
   For Each ws In wb.Worksheets
      vbFeld(i) = ws.Name
      i = i + 1
   Next ws
  
   wb.Close
  
   a = 0
   For Each i In vbFeld
      ActiveCell.Offset(a, 0).Value = i
      a = a + 1
   Next i
  
End Sub

Code strukturiert dargestellt durch 3. Button von rechts im Beitragsformular: #
Moderator [Bild: smilie.php?smile_ID=1810]

[Kuwer]

Hallo,

vielleicht genügt dies Deiner Vorstellung an Eleganz?

Code:

Sub Blattnamenauslesen()
  'Programm zum Auslesen der Tabellenblattnamen
  'aus der geschlossenen Datei Datei.xls im Verzeichnis C:\Test
  Dim i As Long
  Dim rngStart As Range
  Dim sFile As String
  Dim wb As Workbook
  
  Set rngStart = ActiveCell
  Set wb = Workbooks.Open("C:\Test\Datei.xls")
  
  For i = 1 To wb.Worksheets.Count
    rngStart.Offset(i - 1, 0).Value = wb.Worksheets(i).Name
  Next i
  
  wb.Close

End Sub

Gruß Uwe

[ratrad]

Hallo leider funktioniert
dein Code noch nicht.

Klemmt bei ws

[Kuwer]

Hallo,

ja stimmt, da muss jetzt i stehen.

Gruß Uwe

[ratrad]

Hallo Uwe,

danke für Deine Hilfe! Falls andere Leute aber noch andere Vorschläge haben, nur zu.

[schauan]

Hallo ratrad,

aus einer geschlossenen Mappe stimmt ja nun nicht, Du öffnest sie ja zum Auslesen. Es geht aber auch wirklich ohne Öffnen.
Geschlossen braucht einen etwas umfangreicheren code und geht so:

Code:

Option Explicit
'benoetigt Verweis auf Microsoft ActiveX DataObjects
'2.x oder hoeher (getestet mit 2.8 und 6.1)

Private Function ListExcelTablesADOX(ByVal varFile As String, _
                 ListExcelTables As Collection) As Long
Dim objConnection As Object   ' ADODB.Connection
Dim objAdoCat     As Object   ' ADOX.Catalog
Dim tbl           As Object   ' ADOX.Table
  
   'ADODB Connection Objekt setzen - Late Binding
   Set objConnection = CreateObject("adodb.connection")
   'ADODB Catalog Objekt setzen - Late Binding
   Set objAdoCat = CreateObject("adox.catalog")
   'ADODB Connection Verbindung oeffnen
   Set objConnection = OpenExcelConnection(varFile)
   'Bei Fehler Gehe zu Fehlerbehandlung
   On Error GoTo errorhandler
   'Katalog aus ADODB Connection zuweisen
   objAdoCat.ActiveConnection = objConnection
   'Schleife ueber alle Tables
   'Hinweis:
   '1. Druckbereiche ets. werden ebenfalls als Table zurueckgegeben,
   '2. Punkte in Tabellennamen werden in Tables durch hash ersetzt!
   For Each tbl In objAdoCat.Tables
      'wenn Tabellenname mit $ oder $' endet und
      'nicht mit # oder '# beginnt, dann
      If (Right(tbl.Name, 2) = "$'" Or Right(tbl.Name, 1) = "$") And _
         (Left(tbl.Name, 1) <> "#" And Left(tbl.Name, 2) <> "'#") Then
        'Tabellenname zur Collection hinzufuegen
        ListExcelTables.Add tbl.Name
      'Ende wenn Tabellenname mit $ oder $' endet und
      'nicht mit # oder '# beginnt, dann
      End If
   'naechste Schleife ueber alle Tables
   Next tbl
'Fehlerbehandlung
errorhandler:
  'ADODB Catalog zuruecksetzen
  Set objAdoCat = Nothing
  'ADODB Connection schliessen
  objConnection.Close
  'ADODB Connection zuruecksetzen
  Set objConnection = Nothing
'Wenn Fehler, dann Fehlernumer als Rueckgabewert
If Err Then ListExcelTablesADOX = Err.Number
End Function

Private Function OpenExcelConnection( _
  ByVal Path As String, _
  Optional ByVal Headers As Boolean = True) As Connection
  Const adUseClient As Long = 3      ' noetig bei Late Binding
  Dim strConn As String              ' Connection - String, Versionsabhaengig
  Dim objConn As ADODB.Connection    ' Connection-Objekt
  'Connection-Objekt initialisieren
  Set objConn = New ADODB.Connection
  'Wenn excel-Version >= 12, dann
  If Val(Application.Version) >= 12 Then
    'Connection-String mit ACE bilden
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                   "Data Source=" & Path & ";" & _
                   "Extended Properties=""Excel 12.0;HDR=" & _
                   IIf(Headers, "Yes", "No") & """;"
  'Oder nicht Wenn excel-Version >= 12, dann
  Else
    'Connection-String mit Jet bilden
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=" & Path & ";" & _
            "Extended Properties=""Excel 8.0;HDR=" & _
            IIf(Headers, "Yes", "No") & """"
  'Ende Wenn excel-Version >= 12, dann
  End If
  'mit dem Connection Objekt
  With objConn
    'Cursor setzen
    .CursorLocation = adUseClient
    'Verbindung oeffnen
    .Open strConn
  'Ende mit dem Connection Objekt
  End With
  'Connection zurueckgeben
  Set OpenExcelConnection = objConn
End Function

Public Sub BlattNamenHolen()
'Programm holt Blattnamen aus einer geschlossenen Mappe
'und trägt diese auf Tabelle1 ein.
'Variablendeklarationen
'Integer
Dim iCnt1%
'Long
Dim lo_Error&, loLetzte&
'string
Dim strPath$
'Collection
Dim ListExcelTables As New Collection 'Collection mit Blattnamen
'pfadvariable mit Pfad und Dateiname bilden
strPath = "D:\Test\x1.xlsx"
'Liste der Tabellenblaetter der Datei bilden, Rueckgabe Fehlerwert
lo_Error = (ListExcelTablesADOX(strPath, ListExcelTables))
'Mit dem Blatt Suche
With ThisWorkbook.Sheets("Tabelle1")
    'Schleife bis zum Ende der Collection
    For iCnt1 = 1 To ListExcelTables.Count
        'erste freie Zelle anhand Spalte A ermitteln
        loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(loLetzte, 1) = ListExcelTables(iCnt1)
    'Naechste Schleife bis zum Ende der Collection
    Next
'Ende Mit dem Blatt Suche
End With
'Blattliste zuruecksetzen
Set ListExcelTables = Nothing
End Sub

[ratrad]

Hallo Andre,

danke für den Code, aber leider läuft er nicht. Habe eine X64 Version. Natürlich hast du recht. Die Datei bleibt nicht geschlossen und es wird ein bißchen dabei geschummelt.

[schauan]

Hallo ratrad,
Habe nur das 32er Office und kann daher nur raten, was die Ursache sein kann. Was kommt denn für eine Fehlermeldung?

[schauan]

Hallöchen,

beim Auslesen von Tabellennamen weicht das Ergebnis etwas ab.
Es wird in der Regel ein $ an den Tabellennamen angehängt:
Tabelle1$
Tabelle2$
Enthalten die Tabellennamen Punkte, werden diese durch Hash ersetzt:
Tabelle#1$
Tabelle#2$
Tabelle#3$
Bei bestimmten Zeichen werden zusätzlich die Hochkomma am Anfang und Ende ausgegeben, analog z.B. zur Formeleingabe:
'Tabelle#3$'
'Tabelle,3$'
Allerdings ist bei den Ersatzzeichen kein eindeutiger Rückschluss auf die ersetzten Zeichen zu erwarten:
Tabelle!"§$%&()=`'_;
wird zu
'Tabelle_"§$%&()=_''_;$'
Hier sieht man noch den Sonderfall, dass ein Hochkomme im Namen ein zweites davor gesetzt bekommt.

Je nachdem, ob man mit Wildwuchs bei der Zeichenvergabe rechnen muss oder eine Systematik bei der Namensvergabe einhält, kann man reagieren oder auch nicht.

Sind z.B. nur die Indizees der Tabellenblätter durch einen Punkt vom Namen getrennt und es gibt keine weiteren "Besonderheiten", kann man den # durch einen Punkt ersetzen und nimmt den $ vom Ende weg.

Statt

Code:

'Tabellenname zur Collection hinzufuegen
ListExcelTables.Add tbl.Name

kann man dann so reagieren:

Code:

'Tabellenname zur Collection hinzufuegen
ListExcelTables.Add Replace(Replace(tbl.Name,"#","."),"$","")

[schauan]

Hallöchen,

noch ein Hinweis. Sollte bei den Tabellennamen mit den Hochkommas am Anfang und Ende selbiges am Ende stören, kann man das beim Zelleintrag durch eine zusätzliche Codezeile entfernen:
nach dieser Zeile:
       .Cells(loLetzte, 1) = ListExcelTables(iCnt1)
diese einfügen:
      If Right(.Cells(loLetzte, 1), 1) = "" Then .Cells(loLetzte, 1) = Left(.Cells(loLetzte, 1), Len(.Cells(loLetzte, 1)) - 1)

Ein einfaches Replace des Hochkomma beim Auslesen würde nicht funktionieren. Dabei würde auch das Hochkomma am Anfang ersetzt und das ergibt beim Eintrag in die Zelle eine Zahl mit Dezimalstellen.