Dateien eines Ordners als Hyperlink

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo

Hab ich mal irgendwo gefunden.

Option Explicit

Sub DateienAuflisten()
    Dim FileArray(), Tb
    Dim VzPfad As String, DatTyp As String, DatName As String
    Dim n As Integer, TBIndex As Integer, i As Integer
     On Error GoTo Fehler
     If ActiveWorkbook.ProtectStructure = False Then
Verzeichnispfad:
      VzPfad = InputBox("Geben Sie den Verzeichnispfad an." & _
               vbCrLf & vbCrLf & _
               "( Eingabeform: [Laufwerk] :\ [Verzeichnis] )", _
               "Dateiliste erstellen", "F:\Eigene Dateien\Excel")
   If VzPfad = "" Then Exit Sub
      DatTyp = InputBox("Geben Sie den Dateityp an." & _
               vbCrLf & vbCrLf & _
               "( Eingabeform: [Datei-Extension], ' * ' für " & _
               "alle Dateien )", "Dateiliste erstellen", "xls")
   If DatTyp = "" Then Exit Sub
   If Dir(VzPfad, vbDirectory) = "" Then
      MsgBox "Verzeichnispfad ist falsch !  Das Verzeichnis" & _
              vbCrLf & "' " & VzPfad & " '" & _
              vbCrLf & "existiert nicht !", _
              vbExclamation, "Fehlermeldung"
GoTo Verzeichnispfad
  End If
      Application.ScreenUpdating = False
      ChDrive Left(VzPfad, 1)
      ChDir VzPfad
      DatName = Dir("*." & DatTyp)
   Do While DatName <> ""
      n = n + 1
ReDim Preserve FileArray(1 To n)
      FileArray(n) = DatName
      DatName = Dir()
Loop
   If n = 0 Then
      MsgBox "Es wurden keine Dateien dieses Typs gefunden !", _
             vbInformation, "Meldung"
Exit Sub
  End If
      TBIndex = 1
  For Each Tb In Sheets
   If InStr(1, Tb.Name, "Dateiliste") Then
      TBIndex = TBIndex + 1
  End If
Next Tb
With Worksheets.Add
      .Move Before:=Worksheets(1)
      .Name = "Dateiliste (" & TBIndex & ")"
      .Cells.Font.Name = "Tahoma"
      .Cells.Font.Size = 8
      .Cells(5, 2).Font.Bold = True
      .Cells(5, 4).Font.Bold = True
      .Range(Cells(2, 2), Cells(3, 2)).Font.Bold = True
      .Range(Cells(7, 2), Cells(n + 6, 2)).Font.Bold = True
      .Range(Cells(7, 2), Cells(n + 6, 2)).HorizontalAlignment _
       = xlRight
      .Cells(5, 2).HorizontalAlignment = xlCenter
      .Columns(1).ColumnWidth = 2
      .Columns(2).ColumnWidth = 5
      .Columns(3).ColumnWidth = 1
  End With
With ActiveWindow
      .DisplayGridlines = False
      .DisplayHeadings = False
  End With
  For i = 1 To n
With ActiveSheet
      .Cells(2, 2).Value = "Dateiliste von Verzeichnis: " & _
       UCase(VzPfad)
      .Cells(3, 2).Value = "Dateityp: *." & UCase(DatTyp)
      .Cells(5, 2).Value = "- Nr. -"
      .Cells(5, 4).Value = "Datei (Name.Typ)"
      .Cells(i + 6, 2).Value = i & ")"
  End With
   If InStr(1, FileArray(i), ".XL", 1) Then
With ActiveSheet
      .Hyperlinks.Add Anchor:=.Cells(i + 6, 4), Address:= _
       UCase(VzPfad & "\" & FileArray(i))
      .Cells(i + 6, 4).Value = UCase(FileArray(i))
      .Cells(i + 6, 4).Font.Name = "Tahoma"
      .Cells(i + 6, 4).Font.Size = 8
  End With
Else
      ActiveSheet.Cells(i + 6, 4).Value = UCase(FileArray(i))
  End If
Next i
With ActiveSheet
      .Columns(4).EntireColumn.AutoFit
      .Range(Cells(7, 4), Cells(i + 6, 4)).Sort _
      Key1:=ActiveSheet.Range("D7"), Order1:=xlAscending
  End With
      Application.ScreenUpdating = True
      MsgBox "Es wurden " & n & " Dateien dieses Typs" & _
             vbCrLf & "gefunden, aufgelistet und sortiert.", _
             vbInformation, "Meldung"
Else
      MsgBox "Die aktive Arbeitsmappe ist geschuetzt !" & _
             vbCrLf & "Routine kann nicht ausgefuehrt werden.", _
             vbExclamation, "Fehlermeldung"
  End If
Exit Sub
Fehler:
Application.ScreenUpdating = True
MsgBox "Fehler !  Diese Routine wurde beendet." & _
       vbCrLf & Error, _
       vbExclamation, "Fehlermeldung"
End Sub

Code eingefügt mit Syntaxhighlighter 2.4

mfg, GraFri

Beliebteste Forumthreads (12 Monate)

Dateien eines Ordners als Hyperlink

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien eines Ordners als Hyperlink

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread