Microsoft Excel

Herbers Excel/VBA-Archiv

Codeänderung: Dateien und Blätter auflisten | Herbers Excel-Forum


Betrifft: Codeänderung: Dateien und Blätter auflisten von: WalterK
Geschrieben am: 22.01.2012 14:20:51

Hallo,

den folgenden Code habe ich im Forum gefunden. Er listet die .xls-Dateien eines Verzeichnisses auf und führt auch alle Blätter an.

Könnte mir bitte jemand den Code so abändern, dass bei passwortgeschützten Dateien der Code nicht abbricht sondern in der Spalte Tabellen den Vermerk "Passwortschutz" ausgibt.

Wäre es auch möglich, dass der Code neben den .xls-Dateien auch für .xlt, .xlsx und .xlsm-Dateien funktioniert.

Besten Dank für die Hilfe und Servus, Walter
Hier noch der Code:

Option Explicit

Sub linkXLFilesAndSheets()
Dim strPath As String, strFile As String
Dim lngRow As Long, lngIndex As Long
Dim vntSheets As Variant

Range("A3:IV" & Rows.Count).Clear

strPath = Range("B1")

strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")

lngRow = 3

strFile = Dir(strPath & "*.xls*", vbNormal)

Do While strFile <> ""
  Me.Hyperlinks.Add anchor:=Cells(lngRow, 1), _
    Address:=strPath & strFile, _
      SubAddress:="", TextToDisplay:=strFile
    
  vntSheets = GetSheetNames(strPath & strFile)
  
  For lngIndex = 0 To UBound(vntSheets)
    Me.Hyperlinks.Add anchor:=Cells(lngRow, lngIndex + 2), _
      Address:=strPath & strFile & "#" & vntSheets(lngIndex) & _
        "!A1", SubAddress:="", TextToDisplay:=vntSheets(lngIndex)
  Next
    
  lngRow = lngRow + 1
  
  strFile = Dir
Loop

Me.Columns.AutoFit

End Sub

Private Function GetSheetNames(ByVal FileName 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 vntTmp() As Variant

'If Dir(FileName, vbNormal) = "" Then Exit Function
  If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
    strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
        "Data Source=" & FileName & ";"
  ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
    strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & "Extended Properties=""Excel 12.0;HDR= _
YES"";" _
        & "Data Source=" & FileName & ";"
  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 vntTmp(lngIndex)
      vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
      lngIndex = lngIndex + 1
    End If
  Next objADO_Tables

If lngIndex > 0 Then GetSheetNames = vntTmp

objADO_Connection.Close
Set objADO_Catalog = Nothing
Set objADO_Connection = Nothing

End Function 

  

Betrifft: AW: Codeänderung: Dateien und Blätter auflisten von: Josef Ehrensberger
Geschrieben am: 22.01.2012 14:53:08


Hallo Walter,

quick and dirty.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub linkXLFilesAndSheets()
  Dim strPath As String, strFile As String
  Dim lngRow As Long, lngIndex As Long
  Dim vntSheets As Variant
  
  On Error GoTo ErrExit
  
  With Me
    .Range("A3:IV" & Rows.Count).Clear
    
    strPath = .Range("B1")
    
    strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
    
    lngRow = 3
    
    strFile = Dir(strPath & "*.xl*", vbNormal)
    
    Do While strFile <> ""
      .Hyperlinks.Add anchor:=.Cells(lngRow, 1), _
        Address:=strPath & strFile, _
        SubAddress:="", TextToDisplay:=strFile
      
      vntSheets = GetSheetNames(strPath & strFile)
      
      For lngIndex = 0 To UBound(vntSheets)
        .Hyperlinks.Add anchor:=.Cells(lngRow, lngIndex + 2), _
          Address:=strPath & strFile & "#" & vntSheets(lngIndex) & _
          "!A1", SubAddress:="", TextToDisplay:=vntSheets(lngIndex)
      Next
      ContinueLoop:
      lngRow = lngRow + 1
      
      strFile = Dir
    Loop
    
    .Columns.AutoFit
    
    ErrExit:
    
    If Err.Number = -2147467259 Then Resume IsProtected
    
    Exit Sub
    IsProtected:
    .Cells(lngRow, 2) = "Passwortgeschützt!"
    Err.Clear
    GoTo ContinueLoop
  End With
End Sub


Private Function GetSheetNames(ByVal FileName 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 vntTmp() As Variant
  
  'If Dir(FileName, vbNormal) = "" Then Exit Function
  If Mid(FileName, InStrRev(FileName, ".") + 1) = "xls" Then
    strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
      "Data Source=" & FileName & ";"
  ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xls?" Then
    strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
      "Extended Properties=""Excel 12.0;HDR=YES"";" & _
      "Data Source=" & FileName & ";"
  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 vntTmp(lngIndex)
      vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
      lngIndex = lngIndex + 1
    End If
  Next objADO_Tables
  
  If lngIndex > 0 Then GetSheetNames = vntTmp
  
  objADO_Connection.Close
  Set objADO_Catalog = Nothing
  Set objADO_Connection = Nothing
  
End Function






« Gruß Sepp »



  

Betrifft: AW: Codeänderung: Dateien und Blätter auflisten von: WalterK
Geschrieben am: 22.01.2012 15:36:14

Hallo Sepp,

Besten Dank für Deine Hilfe.

Der Code bleibt bei der ersten .xlt-Datei stehen.

Servus, Walter


  

Betrifft: AW: Codeänderung: Dateien und Blätter auflisten von: Josef Ehrensberger
Geschrieben am: 22.01.2012 18:06:37


Hallo Walter,

dann so.

' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Sub linkXLFilesAndSheets()
  Dim strPath As String, strFile As String
  Dim lngRow As Long, lngIndex As Long
  Dim vntSheets As Variant
  
  On Error GoTo ErrExit
  
  With Me
    .Range("A3:IV" & Rows.Count).Clear
    
    strPath = .Range("B1")
    
    strPath = IIf(Right(strPath, 1) = "\", strPath, strPath & "\")
    
    lngRow = 3
    
    strFile = Dir(strPath & "*.xl*", vbNormal)
    
    Do While strFile <> ""
      .Hyperlinks.Add anchor:=.Cells(lngRow, 1), _
        Address:=strPath & strFile, _
        SubAddress:="", TextToDisplay:=strFile
      
      vntSheets = GetSheetNames(strPath & strFile)
      If IsArray(vntSheets) Then
        For lngIndex = 0 To UBound(vntSheets)
          .Hyperlinks.Add anchor:=.Cells(lngRow, lngIndex + 2), _
            Address:=strPath & strFile & "#" & vntSheets(lngIndex) & _
            "!A1", SubAddress:="", TextToDisplay:=vntSheets(lngIndex)
        Next
      Else
        .Cells(lngRow, 2) = "Kein zugriff!"
      End If
      lngRow = lngRow + 1
      
      strFile = Dir
    Loop
    
    .Columns.AutoFit
  End With
  ErrExit:
End Sub


Private Function GetSheetNames(ByVal FileName 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 vntTmp() As Variant
  
  On Error Resume Next
  'If Dir(FileName, vbNormal) = "" Then Exit Function
  If Mid(FileName, InStrRev(FileName, ".") + 1) Like "xl?" Then
    strConString = "Provider=Microsoft.Jet.OLEDB.4.0;" & "Extended Properties=Excel 8.0;" & _
      "Data Source=" & FileName & ";"
  ElseIf Mid(FileName, InStrRev(FileName, ".") + 1) Like "xl??" Then
    strConString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
      "Extended Properties=""Excel 12.0;HDR=YES"";" & _
      "Data Source=" & FileName & ";"
  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 vntTmp(lngIndex)
      vntTmp(lngIndex) = Mid$(strTable, intStart, intLength - (intStart + intPos))
      lngIndex = lngIndex + 1
    End If
  Next objADO_Tables
  
  If lngIndex > 0 Then GetSheetNames = vntTmp
  
  objADO_Connection.Close
  Set objADO_Catalog = Nothing
  Set objADO_Connection = Nothing
  
End Function






« Gruß Sepp »



  

Betrifft: Was soll ich sagen,..... von: WalterK
Geschrieben am: 22.01.2012 18:43:15

Hallo Sepp,

... klasse und perfekt, wie immer wenn Du am Werke bist!

Besten Dank und Servus, Walter


Beiträge aus den Excel-Beispielen zum Thema "Codeänderung: Dateien und Blätter auflisten"