Hallo          Ziel erreicht ....   Juhu

ich habe ein komplett laufendes Programm zum verschieben von Dateien. Mit einem Test Ordrner getestet. Hier mein Testaufbau zum nachbauen.

In einem Testordner liegen zwei weitere Ordner:  Statusliste und Schäden als Ordner.  Im Schäden Ordner zwei Ordner für Kund A, Kunde B

Im Stutusordner sind drei Dateien mit der Überschrift:  Kunde A Schaden 1.xlsx, Kunde A Schaden 2.xlsx, Kunde B Schaden 1

In der Verschiebedatei sind drei Button zum Makro Start:  Ordner_auflisten,   Ordner_suchen_2,  Dateien_verschieben

Das Suchmakro wurde von mir geändert, weil ich einen Gedankenfehler hatte. Der Dateiname in Spalte C ist ja länger als der Ordnername in Spalte G. Mein erster Suchlauf konnte somit nicht erfolgreich sein. Erst durch den Aufbau eines Test Ordners fiel mir der Fehler auf. Sinnvoll ist es den Unterordner Name am letzten "\" abzuschneiden, und in Spalte C nach Dateien suchen wo der Ordnername vorkommt!! Das funktioniert auch erfolgreich.

Anschliessend nach dem Verrschieben listet das 3. Makro automatisch beide Ordner auf, so das man das Verschieben auf Anhieb sieht. Bei mir klappte es einwandfrei. Nun bin ich gespannt wie dieser neue Aufbau bei dir funktioniert? Ich hoffe alles klappt so wie du dir es gewünscht hast. Toi toi toi ...

Hinweis:      ich bin nicht jeden Tag im Forum, pausiere manchmal mehrere Wochen. Diesen Thread beobachtet ich bis zum Wochenende.

mfg Nobody

Modul 1

Option Explicit         '28.9.2021  Nobody  für VBA Forum
Dim lngCount As Long    'Dateien verschieben Makro

'Zelle C1=Status Ordner, G1=Schäden Ordner
'in diesen Zellen bitte Ordnerpfad angeben

Sub Ordner_auflisten()
    With ThisWorkbook.Worksheets("Tabelle4")
        .Range("A4:J1000").Clear
        lngCount = 3    '1.Zeile zum auflistern
        SearchFiles_Status Range("C1"), "*.*"  '"*.pdf"
        lngCount = 3    '1.Zeile zum auflistern
        SearchFiles_Schäden Range("G1"), "*.*"  '"*.pdf"
    End With
End Sub

Private Sub SearchFiles_Status(strFolder As String, strFileName As String)
    Dim objFolder As Object, d As Integer
    Dim objFile As Object, objFSO As Object
    With ThisWorkbook.Worksheets(4)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    lngCount = lngCount + 2
    Cells(lngCount, 3) = strFolder
    Cells(lngCount, 3).Font.ColorIndex = 5
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            lngCount = lngCount + 1: d = d + 1
            Cells(lngCount, 3) = objFile.Name
        End If
    Next
    If d = 0 Then lngCount = lngCount - 2
    For Each objFolder In objFSO.GetFolder(strFolder).SubFolders
        SearchFiles_Status strFolder & "\" & objFolder.Name, strFileName
    Next
    End With
End Sub

Private Sub SearchFiles_Schäden(strFolder As String, strFileName As String)
    Dim objFolder As Object, d As Integer
    Dim objFile As Object, objFSO As Object
    With ThisWorkbook.Worksheets(4)
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    lngCount = lngCount + 2
    Cells(lngCount, 7) = strFolder
    Cells(lngCount, 7).Font.ColorIndex = 5
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            lngCount = lngCount + 1: d = d + 1
            Cells(lngCount, 7) = objFile.Name
        End If
    Next
    If d = 0 Then lngCount = lngCount - 2
    For Each objFolder In objFSO.GetFolder(strFolder).SubFolders
        SearchFiles_Schäden strFolder & "\" & objFolder.Name, strFileName
    Next
    End With
End Sub

Modul 2

Option Explicit         '28.9.2021  Nobody  für VBA Forum
Dim AC As Range, lz1 As Long
Dim Adr1 As String, rFind As Range

Sub Ordner_suchen_2()
Dim SuName As String, n As Integer
With ThisWorkbook.Worksheets("Tabelle4")
     .Range("E4:E1000").Clear
      lz1 = .Cells(Rows.Count, 7).End(xlUp).Row
      Application.ScreenUpdating = False
    
      For Each AC In .Range("G5:G" & lz1)
         If InStr(AC, ":\") Then
         'Kunden Ordner ermitteln  (Pfad abschneiden)
         SuName = Trim(Mid(AC, InStrRev(AC, "\") + 1))
         Set rFind = .Columns(3).Find(What:=SuName, After:=[c5], LookIn:=xlFormulas, LookAt:= _
             xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)

         If Not rFind Is Nothing Then
            Adr1 = rFind.Address
            Do
               If InStr(rFind, SuName) Then
                  rFind.Offset(0, 1) = AC.Value
                  n = n + 1
               End If
               Set rFind = .Columns(3).FindNext(rFind)
            Loop Until rFind.Address = Adr1
         End If
nx:      End If
      Next AC
      MsgBox n & "  Dateien markiert"
End With
End Sub

Modul 3

Option Explicit         '28.9.2021  Nobody  für VBA Forum
Dim AC As Range, lz1 As Long

Sub Dateien_verschieben()
Dim quelle As String, n As Integer
Dim Ziel As String, Datei As String
With ThisWorkbook.Worksheets("Tabelle4")
      lz1 = .Cells(Rows.Count, 3).End(xlUp).Row
      Application.ScreenUpdating = False
      
      For Each AC In .Range("C5:C" & lz1)
         If InStr(AC, ":\") Then GoTo nx
         If AC.Offset(0, 1) <> Empty Then
            Datei = Trim(AC)
            quelle = Range("C1") & "\" & Datei
            Ziel = AC.Offset(0, 1) & "\" & Datei
            Name quelle As Ziel
            n = n + 1
nx:      End If
      Next AC
      MsgBox n & "  Dateien verschoben"
      Call Ordner_auflisten
End With
End Sub