VBA Dateien in anderen Ordner kopieren mit Bedingung

Sub CopyMatchingFiles()

    Dim sourceFolder As String

    Dim destinationFolder As String

    Dim fileSystem As Object

    Dim sourceFile As Object

    Dim fileName As String

    Dim baseFileName As String

    Dim modifiedBaseFileName As String

    Dim modifiedBaseFileNameWithReplace As String

    Dim modifiedBaseFileNameWithSeen As String

    Dim destinationFiles As Object

    Dim destinationFile As Object

    Dim matchFound As Boolean

    Dim searchTermDict As Object

    Dim key As Variant

    Dim ws As Worksheet

    Dim lastWord As String



    ' Bildschirmaktualisierung und Berechnung ausschalten

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual

    Application.EnableEvents = False



    On Error GoTo Cleanup



    ' Ordnerpfade festlegen

    sourceFolder = "E:\Videos"

    destinationFolder = "E:\U30"

    Set ws = Worksheets("Rechnung")



    ' Suchbegriffe aus Rechnung!H2:H31 in ein Dictionary laden

    Set searchTermDict = CreateObject("Scripting.Dictionary")

    For Each cell In ws.Range("H2:H31")

        If cell.Value > "" Then

            searchTermDict(cell.Value) = True

        End If

    Next cell



    ' Dateisystemobjekt erstellen

    Set fileSystem = CreateObject("Scripting.FileSystemObject")



    ' Zielordner-Dateien zwischenspeichern

    Set destinationFiles = CreateObject("Scripting.Dictionary")

    For Each destinationFile In fileSystem.GetFolder(destinationFolder).Files

        destinationFiles(fileSystem.GetBaseName(destinationFile.Name)) = True

    Next destinationFile



    ' Dateien im Quellordner durchlaufen

    For Each sourceFile In fileSystem.GetFolder(sourceFolder).Files

        fileName = sourceFile.Name

        ' Basis-Dateinamen ermitteln (ohne Nummer und Dateiendung)

        baseFileName = fileSystem.GetBaseName(fileName)



        ' Basis-Dateinamen modifizieren (letztes Wort entfernen, durch "löschen" oder "gesehen" ersetzen)

        lastWord = GetLastWord(baseFileName)

        modifiedBaseFileName = RemoveLastWord(baseFileName) ' Letztes Wort entfernen

        modifiedBaseFileNameWithReplace = ReplaceLastWordWith(baseFileName, "löschen") ' Letztes Wort durch "löschen" ersetzen

        modifiedBaseFileNameWithSeen = ReplaceLastWordWith(baseFileName, "gesehen") ' Letztes Wort durch "gesehen" ersetzen



        ' Debugging: Geben Sie die Dateinamen aus, um zu sehen, welche Varianten erstellt werden

        Debug.Print "Quelle: " & baseFileName

        Debug.Print "Modifiziert: " & modifiedBaseFileName

        Debug.Print "Mit 'löschen': " & modifiedBaseFileNameWithReplace

        Debug.Print "Mit 'gesehen': " & modifiedBaseFileNameWithSeen



        ' Prüfen, ob der modifizierte Basisname mit einem der Suchbegriffe übereinstimmt

        matchFound = False

        For Each key In searchTermDict.Keys

            If InStr(1, modifiedBaseFileName, key, vbTextCompare) > 0 Or _

               InStr(1, modifiedBaseFileNameWithReplace, key, vbTextCompare) > 0 Or _

               InStr(1, modifiedBaseFileNameWithSeen, key, vbTextCompare) > 0 Then

                matchFound = True

                Exit For

            End If

        Next key



        ' Weitere Übereinstimmungen prüfen, wenn die Datei im Zielordner existiert

        If matchFound Then

            If destinationFiles.Exists(modifiedBaseFileName) Or _

               destinationFiles.Exists(modifiedBaseFileNameWithReplace) Or _

               destinationFiles.Exists(modifiedBaseFileNameWithSeen) Then

                ' Datei kopieren, wenn Übereinstimmung gefunden wurde

                Debug.Print "Kopieren: " & fileName ' Debugging: Ausgabe der zu kopierenden Datei

                fileSystem.CopyFile sourceFile.Path, fileSystem.BuildPath(destinationFolder, fileName)

            Else

                Debug.Print "Keine Übereinstimmung für: " & fileName ' Debugging: Wenn keine Übereinstimmung gefunden wird

            End If

        End If



        ' DoEvents hier aufrufen, um Excel reaktionsfähig zu halten

        DoEvents

    Next sourceFile



Cleanup:

    ' Bildschirmaktualisierung und Berechnung wieder einschalten

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

    Application.EnableEvents = True



    MsgBox "Der Kopiervorgang ist abgeschlossen.", vbInformation

End Sub



' Funktion, um das letzte Wort aus einem Dateinamen zu entfernen

Function RemoveLastWord(baseName As String) As String

    Dim words() As String

    Dim i As Long

    Dim result As String



    ' Namen in Wörter aufteilen

    words = Split(baseName, " ")

    

    ' Wenn es nur ein Wort gibt, bleibt der Name gleich

    If UBound(words) = 0 Then

        RemoveLastWord = baseName

        Exit Function

    End If



    ' Alle Wörter außer dem letzten zusammenfügen

    For i = LBound(words) To UBound(words) - 1

        If result > "" Then result = result & " "

        result = result & words(i)

    Next i



    RemoveLastWord = result

End Function



' Funktion, um das letzte Wort im Dateinamen durch einen angegebenen Wert zu ersetzen

Function ReplaceLastWordWith(baseName As String, replacement As String) As String

    Dim words() As String

    Dim i As Long

    Dim result As String



    ' Namen in Wörter aufteilen

    words = Split(baseName, " ")



    ' Wenn es nur ein Wort gibt, bleibt der Name gleich

    If UBound(words) = 0 Then

        ReplaceLastWordWith = baseName

        Exit Function

    End If



    ' Alle Wörter außer dem letzten zusammenfügen und das letzte Wort durch den angegebenen Ersatz ersetzen

    For i = LBound(words) To UBound(words) - 1

        If result > "" Then result = result & " "

        result = result & words(i)

    Next i



    ReplaceLastWordWith = result & " " & replacement

End Function



' Funktion, um das letzte Wort aus einem Dateinamen zu extrahieren

Function GetLastWord(baseName As String) As String

    Dim words() As String

    words = Split(baseName, " ")

    GetLastWord = words(UBound(words))

End Function