VBA: Code anpassen

Fritz_W · 2024-08-07T10:59:03+00:00

Hallo Forumsbesucher mit dem nachstehenden Code liste ich im aktuellen Tabellenblatt, die Dateien des im Code festgelegten Ordners auf. Ich würde gerne mit einem geänderten Code erreichen, dass der Pfad mit dem auszulesenden Ordner nicht direkt im Makro festgelegt wird, sondern im aktuellen Tabellenplatz in der Zelle H1 einzugeben ist. Sollte das festgelegte Verzeichnis (Ordner) nicht existieren, sollte eine entsprechende Meldung ausgegeben werden. Für eure Unterstützung im Voraus besten Dank mfg Fritz Hier der aktuelle Code: Sub Dateien_eines_Ordners_auflisten() Dim lngZeile As Long Dim objFilesystem As Object Dim objVerzeichnis As Object Dim objDateienliste As Object Dim objDatei As Object Set objFilesystem = CreateObject("scripting.FileSystemObject") Set objVerzeichnis = objFilesystem.GetFolder("D:\Fritz\Videos Tiere") Set objDateienliste = objVerzeichnis.Files lngZeile = 2 For Each objDatei In objDateienliste If Not objDatei Is Nothing Then ActiveSheet.Cells(lngZeile, 2) = objDatei.Name lngZeile = lngZeile + 1 End If Next objDatei End Sub

Moin Fritz!
Teste mal.

Sub Dateien_eines_Ordners_auflisten_2()

  

  Dim lngZeile As Long

  Dim objFilesystem As Object

  Dim objVerzeichnis As Object

  Dim objDateienliste As Object

  Dim objDatei As Object

  Dim vntOUT()

  

  Set objFilesystem = CreateObject("scripting.FileSystemObject")

  

  If objFilesystem.folderexists(Worksheets("Tierfilme").Range("H1")) Then

    Set objVerzeichnis = objFilesystem.GetFolder(Worksheets("Tierfilme").Range("H1"))

  Else

    If Worksheets("Tierfilme").Range("H1") = "" Then

      MsgBox "H1 ist leer"

      Exit Sub

    Else

      MsgBox "Pfad gibt es nicht"

      Exit Sub

    End If

  End If

  

  Set objDateienliste = objVerzeichnis.Files

  If objDateienliste.Count = 0 Then

    MsgBox "Der Ordner ist leer"

  End If

  

  lngZeile = 1

  Worksheets("Tierfilme").Columns(2).ClearContents

  ReDim vntOUT(1 To objDateienliste.Count, 1 To 1)

  

  For Each objDatei In objDateienliste

    vntOUT(lngZeile, 1) = objDatei.Name

    lngZeile = lngZeile + 1

  Next objDatei

  

  Worksheets("Tierfilme").Cells(2, 2).Resize(objDateienliste.Count) = vntOUT

End Sub

P.S.: Evtl. musst du noch vor das Worksheet ThisWorkbook. schreiben, also ThisWorkbook.Worksheets("Tierfilme"). _ _ _

Gruß Gerd

Hallo,
aus meinem Archiv:

Public Sub Dateieigenschaften()

 '    Const FOLDER_PATH As String = "C:\test"

     Const MAX_PROPERTYS As Long = 1000

     

     Dim objShell As Object, objFolder As Object

     Dim lngIndex As Long, lngRow As Long, lngMaxCount As Long

     Dim vntName As Variant

     Dim strTemp As String

     '

     Dim FOLDER_PATH

     With Application.FileDialog(msoFileDialogFolderPicker)

       If .Show = -1 Then

         FOLDER_PATH = .SelectedItems(1)

       End If

     End With

     '

     If Dir$(FOLDER_PATH, vbDirectory) > vbNullString Then

         'Debug.Print FOLDER_PATH

         Application.ScreenUpdating = False

         

         Cells.Clear

         

         Set objShell = CreateObject("Shell.Application")

         Set objFolder = objShell.Namespace(FOLDER_PATH)

         

         For lngIndex = 0 To MAX_PROPERTYS

            strTemp = objFolder.GetDetailsOf(vntName, lngIndex)

            If strTemp = vbNullString Then

                lngMaxCount = lngMaxCount - 1

                Exit For

            Else

                Cells(1, lngIndex + 1).Value = strTemp

                lngMaxCount = lngMaxCount + 1

            End If

        Next

        

        Rows(1).Font.Bold = True

        lngRow = 2

        

        For Each vntName In objFolder.Items

            For lngIndex = 0 To lngMaxCount

                Cells(lngRow, lngIndex + 1).Value = _

                    objFolder.GetDetailsOf(vntName, lngIndex)

            Next

            lngRow = lngRow + 1

        Next

        

        Columns.AutoFit

        Application.ScreenUpdating = True

        

    Else

        MsgBox "Der Ordner " & FOLDER_PATH & " wurde nicht gefunden!", _

            vbExclamation, "weise hin..."

    End If

End Sub

Gruß aus'm Pott
Udo

Forumthread: VBA: Code anpassen

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

VBA: Code anpassen

Forumthread: VBA: Code anpassen

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread