Dateien anhand Liste suchen und kopieren

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\" '

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

Beliebteste Forumthreads (12 Monate)

Dateien anhand Liste suchen und kopieren

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

241 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateien anhand Liste suchen und kopieren

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

241 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread