Ordnerinhalt darstellen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo ? (Hast du auch einen Namen?)
Das könnte man z.B. so lösen.

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

Option Explicit

Private Sub Workbook_Open()
Dateien_Auflisten
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopTimer
End Sub

Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Application.CommandBars("Web").Visible = False
End Sub

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Dim RunWhen As Double
Const cRunIntervalSeconds = 60 ' Aktualisierungsintervall in Sekunden - Anpassen
Const cRunWhat = "Dateien_Auflisten"

Sub StartTimer()
RunWhen = Now + TimeSerial(0, 0, cRunIntervalSeconds)
Application.OnTime earliesttime:=RunWhen, procedure:=cRunWhat, _
  schedule:=True
End Sub

Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=RunWhen, _
  procedure:=cRunWhat, schedule:=False
End Sub

Sub Dateien_Auflisten()

'by J.Ehrensberger

Dim fSearch As FileSearch
Dim wkb As Workbook
Dim strPath As String
Dim iCnt As Integer
Dim objSH As Worksheet

Dim lngCalculation As Long

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
End With

Set objSH = ThisWorkbook.Sheets("Tabelle1") 'Tabelenname anpassen!
objSH.Columns("A:B").Clear

strPath = "F:\Office\Excel"

If strPath = "" Then Exit Sub

Set fSearch = Application.FileSearch

With fSearch
  .NewSearch
  .LookIn = strPath
  .SearchSubFolders = False '<<<<Unterordner durchsuchen True/False
  .FileType = msoFileTypeExcelWorkbooks
  If .Execute > 0 Then

    For iCnt = 1 To .FoundFiles.Count

      objSH.Cells(iCnt, 1) = .FoundFiles(iCnt)
      objSH.Cells(iCnt, 2) = FileDateTime(.FoundFiles(iCnt))
      objSH.Hyperlinks.Add Anchor:=objSH.Cells(iCnt, 1), Address:= _
        objSH.Cells(iCnt, 1).Text, TextToDisplay:=objSH.Cells(iCnt, 1).Text
    Next

  End If

End With

objSH.Columns("A:B").AutoFit
objSH.Columns("A:B").Sort key1:=objSH.Range("B1"), _
  order1:=xlDescending, _
  key2:=objSH.Range("A1"), _
  order2:=xlDescending

ErrExit:

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
End With

Set fSearch = Nothing
Set objSH = Nothing

StartTimer

End Sub

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread