Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Dateien anhand Liste suchen und kopieren

Betrifft: Dateien anhand Liste suchen und kopieren von: Alexander
Geschrieben am: 12.10.2020 12:27:41

Hallo zusammen,

die Frage wurde so ähnlich schon öfter gestellt, dennoch finde ich für meine Anwendung keine passende Lösung.

Ich habe eine Liste (Spalte A) mit Bauteilnummern, die teilweise mehrmals in dieser Liste vorkommen können.
Anhand dieser Bauteilnummern möchte ich zugehörige Zeichnungen in .pdf und. dwg aus einem Hauptverzeichnis und dessen
Unterverzeichnissen suchen und in ein bestimmtes Verzeichnis kopieren. Dabei beinhaltet der Dateiname die gesuchte Bauteilnummer.

Beispiel:
Bauteilnummer: 12314-0000-01
Existierende Zeichnungen: 12314-0000-01_Geländer.pdf und 12314-0000-01_Geländer.dwg

Ganz ähnlich ist die Lösung von Dieter Klemke.
Allerdings müsste ich im Hauptverzeichnis und allen Unterverzeichnissen suchen.
Dazu kommt dass manche Bauteilnummern mehrfach auftauchen aber nur einmal kopiert werden soll.
Und es soll kopiert und nicht verschoben werden.
Außerdem soll der Original-Dateiname beibehalten werden. Keine Ergänzung wie in dem Beispiel.

Optimalerweise steht dann bei kopierten Bauteilen in Spalte B eine "1", bei nicht gefundenen eine"0" und bei nicht kopierten (weil mehrfach vorkommend) ein "X".

Leider bin ich in VBA eine komplette Niete und kann den Code von Dieter nicht umbauen.
Vielleich kann mir jemand helfen? Das wäre Wahnsinn!
Vielen Dank im Voraus!!!

Hier der Code von Dieter:

Sub PDFs_suchen()
  Dim anzVerschoben As Long
  Dim fil As File
  Dim folQ As Folder  ' Quelle
  Dim folZ As Folder  ' Ziel
  Dim fso As FileSystemObject
  Dim letzteZeile As Long
  Dim suchBegriff As String
  Dim suchMuster As String
  Dim verzQuelle As String
  Dim verzZiel As String
  Dim wb As Workbook
  Dim ws As Worksheet
  Dim zeile As Long
  Dim zf As String
  
  Set wb = ThisWorkbook
  verzQuelle = wb.Path & "\Test-Quelle\"      ' <-- Hier das gewünschte Verzeichnis einsetzen
  verzZiel = wb.Path & "\Test-Ziel\"          ' <-- Hier das gewünschte Verzeichnis einsetzen
  Set ws = wb.Worksheets(1)
  ws.Columns("B").ClearContents
  letzteZeile = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
  Set fso = New FileSystemObject
  If Not fso.FolderExists(FolderSpec:=verzQuelle) Then
    MsgBox verzQuelle & " existiert nicht"
    Exit Sub
  End If
  If Not fso.FolderExists(FolderSpec:=verzZiel) Then
    MsgBox verzZiel & " existiert nicht"
    Exit Sub
  End If
  Set folQ = fso.GetFolder(FolderPath:=verzQuelle)
  Set folZ = fso.GetFolder(FolderPath:=verzZiel)
  For zeile = 2 To letzteZeile
    suchBegriff = ws.Cells(zeile, "A")
    suchMuster = UCase$(suchBegriff & "*.pdf")
    anzVerschoben = 0
    For Each fil In folQ.Files
      If UCase$(fil.Name) Like suchMuster Then
        zf = fil.Name
        zf = Replace(zf, suchBegriff, suchBegriff & "_WU")
        fil.Name = zf
        fil.Move Destination:=verzZiel
        anzVerschoben = anzVerschoben + 1
      End If
    Next fil
    ws.Cells(zeile, "B") = anzVerschoben
  Next zeile
  Set fso = Nothing
End Sub

Betrifft: AW: Dateien anhand Liste suchen und kopieren
von: Nepumuk
Geschrieben am: 12.10.2020 13:07:34

Hallo Alexander,

teste mal:

Option Explicit

Public Sub CopyFiles()
    Const INPUT_PATH As String = "G:\DATEN\" 'Anpassen !!! Backslash am Ende nicht löschen
    Const OUTPUT_PATH As String = "H:\OUTPUT\" 'Anpassen !!! Backslash am Ende nicht löschen
    Dim astrFolders() As String, strFilename As String
    Dim avntValues As Variant, vntItem As Variant
    Dim ialngFolders As Long, ialngIndex As Long, lngCount As Long
    Dim objDictionary As Object
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    Range(Cells(2, 2), Cells(Rows.Count, 2)).ClearContents
    avntValues = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Value2
    With objDictionary
        For ialngIndex = LBound(avntValues) To UBound(avntValues)
            If Not .Exists(Key:=avntValues(ialngIndex, 1)) Then
                Call .Add(Key:=avntValues(ialngIndex, 1), Item:=ialngIndex + 1)
            Else
                Cells(ialngIndex + 1, 2).Value = "X"
            End If
        Next
        astrFolders = GetFolders(INPUT_PATH)
        For Each vntItem In .Keys
            lngCount = 0
            For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
                strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.pdf")
                If strFilename <> vbNullString Then
                    Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:=OUTPUT_PATH & strFilename)
                    lngCount = 1
                End If
                strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.dwg")
                If strFilename <> vbNullString Then
                    Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:=OUTPUT_PATH & strFilename)
                    lngCount = lngCount + 1
                End If
                If lngCount = 2 Then Exit For
            Next
            If lngCount = 0 Then
                Cells(.Item(Key:=vntItem), 2).Value = 0
            Else
                Cells(.Item(Key:=vntItem), 2).Value = 1
            End If
        Next
    End With
    Set objDictionary = Nothing
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()
    Dim astrFolders() As String
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    Redim Preserve astrFolders(ialngIndex1)
    astrFolders(ialngIndex1) = pvstrPath
    ialngIndex1 = 1
    ialngIndex2 = 1
    strPath = pvstrPath
    Do
        strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
                    Redim Preserve astrFolders(0 To ialngIndex1)
                    astrFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = astrFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = astrFolders
End Function

Gruß
Nepumuk

Betrifft: AW: Dateien anhand Liste suchen und kopieren
von: Alexander
Geschrieben am: 12.10.2020 14:53:38

schonmal Danke für die schnelle Antwort!

Funktioniert fast perfekt. Wenn ich als Pfad den Ordner angebe, in dem die Dateien direkr liegen, oder dem übergeordneten, geht das wunderbar. Wenn ich aber in der Hierarchie 2 oder mehr Ordner nach oben gehe und dort suche, bekomme ich die Fehlermeldung "Laufzeitfehler 52: Dateiname oder -nummer falsch".
Diese Zeile wird angezeigt: If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then

Ich hoffe es ist einigermaßen klar was ich meine.

Was könnte ich da machen?

Betrifft: AW: Dateien anhand Liste suchen und kopieren
von: Nepumuk
Geschrieben am: 12.10.2020 14:56:46

Hallo Alexander,

dann hast du den abschließenden Backslash gelöscht.

Gruß
Nepumuk

Betrifft: AW: Dateien anhand Liste suchen und kopieren
von: Alexander
Geschrieben am: 12.10.2020 15:48:52

dachte ich auch. Aber daran scheint es nicht zu liegen.
Hab alles probiert.

Betrifft: AW: Dateien anhand Liste suchen und kopieren
von: Nepumuk
Geschrieben am: 12.10.2020 15:58:44

Hallo Alexander,

dann zeig mal den geänderten Code.

Gruß
Nepumuk

Betrifft: AW: Dateien anhand Liste suchen und kopieren
von: Alexander
Geschrieben am: 12.10.2020 16:06:36

Option Explicit
Public Sub CopyFiles()
    Const INPUT_PATH As String = "W:\Vault_Wustec\CAD\Projekte\" 'Anpassen !!! Backslash am  _
Ende nicht löschen
    Const OUTPUT_PATH As String = "C:\Users\Alex\Desktop\Neuer Ordner\Test-Ziel\" 'Anpassen !!!  _
Backslash am Ende nicht löschen
    Dim astrFolders() As String, strFilename As String
    Dim avntValues As Variant, vntItem As Variant
    Dim ialngFolders As Long, ialngIndex As Long, lngCount As Long
    Dim objDictionary As Object
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    Range(Cells(2, 2), Cells(Rows.Count, 2)).ClearContents
    avntValues = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Value2
    With objDictionary
        For ialngIndex = LBound(avntValues) To UBound(avntValues)
            If Not .Exists(Key:=avntValues(ialngIndex, 1)) Then
                Call .Add(Key:=avntValues(ialngIndex, 1), Item:=ialngIndex + 1)
            Else
                Cells(ialngIndex + 1, 2).Value = "X"
            End If
        Next
        astrFolders = GetFolders(INPUT_PATH)
        For Each vntItem In .Keys
            lngCount = 0
            For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
                strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.pdf")
                If strFilename <> vbNullString Then
                    Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:= _
OUTPUT_PATH & strFilename)
                    lngCount = 1
                End If
                strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.dwg")
                If strFilename <> vbNullString Then
                    Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:= _
OUTPUT_PATH & strFilename)
                    lngCount = lngCount + 1
                End If
                If lngCount = 2 Then Exit For
            Next
            If lngCount = 0 Then
                Cells(.Item(Key:=vntItem), 2).Value = 0
            Else
                Cells(.Item(Key:=vntItem), 2).Value = 1
            End If
        Next
    End With
    Set objDictionary = Nothing
End Sub

Private Function GetFolders(ByVal pvstrPath As String) As String()
    Dim astrFolders() As String
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    ReDim Preserve astrFolders(ialngIndex1)
    astrFolders(ialngIndex1) = pvstrPath
    ialngIndex1 = 1
    ialngIndex2 = 1
    strPath = pvstrPath
    Do
        strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
                    ReDim Preserve astrFolders(0 To ialngIndex1)
                    astrFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = astrFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = astrFolders
End Function



Bei W:\Vault_Wustec\CAD\Projekte\11123_G26 BEV\11123-1600_Geländer\ funktioniert das Ganze
Bei W:\Vault_Wustec\CAD\Projekte\11123_G26 BEV\ auch.

Bei W:\Vault_Wustec\CAD\Projekte\ nicht mehr.

Betrifft: AW: Dateien anhand Liste suchen und kopieren
von: Nepumuk
Geschrieben am: 12.10.2020 16:17:24

Hallo Alexander,

lass das Programm mal in den Fehler laufen. Dann geh mit der Maus über die Variablen strPath und strFolder, oder gib unten im Direktbereich ?strPath ein und drück Enter, das selbe mit der Variablen strFolder, also ?strFolder und Enter. Poste die Ausgabe.

Gruß
Nepumuk

Betrifft: AW: Dateien anhand Liste suchen und kopieren
von: Alexander
Geschrieben am: 12.10.2020 17:36:03

ah, jetzt haben wir das Problem.
Bei der Suche ist Excel auf diverse Dateien mit Sonderzeichen wie Apostroph usw. gestoßen.
Diese habe ich jetzt beseitigt. Jetzt läufts!!!
Hurra! Vielen, vielen Dank Nepumuk!