Dateinamen aus Verzeichnis kopieren

Sub Dateienliste() Dim lngZeile As Long Dim objFileSystem As Object Dim objVerzeichnis As Object Dim objDateienliste As Object Dim objDatei As Object Dim Qpfad As Object Dim i As Long Set Qpfad = ActiveSheet.Range(N2) Set objFileSystem = CreateObject(scripting.FileSystemObject) Set objVerzeichnis = objFileSystem.GetFolder(Qpfad) Set objDateienliste = objVerzeichnis.Files lngZeile = 3 For Each objDatei In objDateienliste If Not objDatei Is Nothing Then ActiveSheet.Cells(lngZeile, 3) = objDatei.Name lngZeile = lngZeile + 1 End If Next objDatei End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Code: [Cc] Sub Dateienliste() Dim vGefunden As Variant Dim objDatei As Object, sDatei As String With CreateObject("scripting.FileSystemObject").GetFolder(Range("N2")) For Each objDatei In .Files If Not objDatei Is Nothing Then sDatei = Replace(objDatei.Name, "~$", "") vGefunden = Application.Match(sDatei, Columns(3), 0) If IsError(vGefunden) Then Cells(Cells(Rows.Count, 3).End(xlUp).Row + 1, "C").Value = sDatei End If End If Next objDatei End With End Sub

Hallo Karl-Heinz,
danke für deine Hilfe.
Dein Makro funktioniert auf dem ersten Blick genau wie meins.
Ich versuche mein Problem anders zu erklären. In der Beispieldatei die ich geladen habe sind in Spalte B die Ordner ABC1, ABC2, ABC3....usw. mit der Hand eingetippt (das soll auch so bleiben).
Jeder Ordner hat mehrere Dateien.
In Spalte C sollen dann die Dateinamen auftauchen die im jeweiligen Ordner liegen.
Die Anzahl der Dateien in den jeweiligen Ordner kann unterschiedlich sein.
Sprich wenn mal in einem Ordner eine Datei neu hinzugekommen ist, darf die neue Datei bei der Übertragung keine alten Einträge überschreiben, sie dürfen also nur in der Liste für den jeweiligen Ordner ans Ende gestellt werden.
Ich hoffe du kannst mir helfen :-)
Mit freundlichen Grüßen
Dennis

Code: [Cc][+][-] Option Explicit Option Compare Text Sub Dateienliste() Dim i As Long Dim oRng As Range Dim oDatei As Object, MA As Object, oFS As Object Dim sErw As String, sPfad As String Set oFS = CreateObject("scripting.FileSystemObject") sErw = "XLS*" ' Ggf. Einschränkungen beachten ' Alle Ordner-Felder durchgehen Application.ScreenUpdating = False For Each oRng In Range("B3:B" & Cells(Rows.Count, 2).End(xlUp).Row) If Not IsEmpty(oRng.Value) Then ' Ist Eintrag vorhanden? Set MA = oRng.MergeArea ' Verketteter Bereich sPfad = Replace(Range("N2").Value & "\" & oRng.Value, "\\", "\") If Dir$(sPfad, vbDirectory) <> "" Then ' Ist der gewünschte Pfad vorhanden? With oFS.GetFolder(sPfad) For Each oDatei In .Files ' Alle Dateien im Ordner durchgehen If Not oDatei Is Nothing Then If oDatei.Name Like "*." & sErw Then For i = oRng.Row To Rows.Count If oDatei.Name Like Cells(i, "C").Value Then Exit For If Cells(i, "C").Value = "" Then ' Zeile einfügen und neu verbinden If i >= (oRng.Row + oRng.MergeArea.Rows.Count) Then Cells(i, "C").EntireRow.Insert ' Zeile einfügen Range("B" & oRng.Row & ":B" & i).Merge End If Cells(i, "C").Value = oDatei.Name ' Wert einsetzen Exit For End If Next i End If End If Next oDatei End With End If End If Next oRng Application.ScreenUpdating = True End Sub

Code: [Cc][+][-] Option Explicit Option Compare Text Sub Dateienliste() Dim i As Long Dim oRng As Range Dim oDatei As Object, oFS As Object Dim sErw As String, sPfad As String Set oFS = CreateObject("scripting.FileSystemObject") sErw = "XLS*" ' Ggf. Einschränkungen beachten Application.ScreenUpdating = False ' Alle Ordner-Felder durchgehen For Each oRng In Range("B3:B" & Cells(Rows.Count, 2).End(xlUp).Row) If Not IsEmpty(oRng.Value) Then ' Ist Eintrag vorhanden? sPfad = Replace(Range("N2").Value & "\" & oRng.Value, "\\", "\") If Dir$(sPfad, vbDirectory) <> "" Then ' Ist der gewünschte Pfad vorhanden? With oFS.GetFolder(sPfad) For Each oDatei In .Files ' Alle Dateien im Ordner durchgehen If Not oDatei Is Nothing Then If oDatei.Name Like "*." & sErw Then For i = oRng.Row To Rows.Count If oDatei.Name Like Cells(i, "C").Value Then Exit For If Cells(i, "C").Value = "" Then ' Zeile einfügen und neu verbinden If i >= (oRng.Row + oRng.MergeArea.Rows.Count) Then Cells(i, "C").EntireRow.Insert ' Zeile einfügen Range("B" & oRng.Row & ":B" & i).Merge End If Cells(i, "C").Value = oDatei.Name ' Wert einsetzen Exit For End If Next i End If End If Next oDatei End With End If End If Next oRng Application.ScreenUpdating = True End Sub

Hallo Dennis,
ich habe das noch mal neu aufgesetzt. Schau mal, ob es jetzt besser passt.

Code:


[Cc][+][-]

Option Explicit
Option Compare Text

Sub Dateienliste()
  Dim i As Long, iZeile As Long
  Dim oRng As Range
  Dim oDatei As Object, oFS As Object
  Dim sErw As String, sPfad As String
  
  Set oFS = CreateObject("scripting.FileSystemObject")
  sErw = "XLS*"                                             ' Ggf. Einschränkungen beachten
  Application.ScreenUpdating = False

' Alle Ordner-Felder durchgehen
  iZeile = 3
  Do
     Set oRng = Cells(iZeile, "B")
     If oRng.MergeArea.Count < 2 Then Exit Do               ' Ende Datenbereich =>raus
       
     If Not IsEmpty(oRng.Value) Then                        ' Ist Eintrag vorhanden?
        sPfad = Replace(Range("N2").Value & "&bsol;" & oRng.Value, "&bsol;&bsol;", "&bsol;")
         
        If Dir$(sPfad, vbDirectory) <> "" Then          ' Ist der gewünschte Pfad vorhanden?
            
           With oFS.GetFolder(sPfad)
              For Each oDatei In .Files                 ' Alle Dateien im Ordner durchgehen
                  If Not oDatei Is Nothing Then
                     If oDatei.Name Like "*." & sErw Then   ' Gewünschte Datei?
                        
                        For i = iZeile To (iZeile + oRng.MergeArea.Rows.Count - 1)
                            If oDatei.Name Like Cells(i, "C").Value Then
                               Exit For
                            ElseIf Cells(i, "C").Value = "" Then
                               Cells(i, "C").Value = oDatei.Name ' Wert einsetzen
                               Exit For
                            End If
                        Next i
                                
                        If i >= (oRng.Row + oRng.MergeArea.Rows.Count) Then
' Zeile einfügen und neu verbinden
                           Cells(i, "C").EntireRow.Insert       ' Zeile einfügen
                           Range("B" & oRng.Row & ":B" & i).Merge
                           Cells(i, "C").Value = oDatei.Name    ' Wert einsetzen
                        End If
                      
                      End If
                  End If
              Next oDatei
           End With
               
        End If
      
     End If
     iZeile = iZeile + oRng.MergeArea.Count
     DoEvents
  Loop

  Application.ScreenUpdating = True
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

Dateinamen aus Verzeichnis kopieren

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread