Sorry Code an vorheriger Antwort nicht angehangen

wenn du die Auflistung von den Spalten her anders gestaltet haben willst können wir das ändern. Schade das du keine Beispiledatei hochladen kannst! Dann könntest du mir deine Ideen und Lösungsvorschlage von Hand eintragen. Ich warte mal auf deine Antwort ...

mfg  Nobody

Option Explicit
Dim lngCount As Long

Public Sub Test_3()
    With ThisWorkbook.Worksheets("Tabelle4")
        .Range("A4:F1000").Clear
        lngCount = 3    '1.Zeile zum auflistern
        SearchFiles_Status Range("C1"), "*.*"  '"*.pdf"
        lngCount = 3    '1.Zeile zum auflistern
        SearchFiles_Schäden Range("F1"), "*.*"  '"*.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, 6) = strFolder
    Cells(lngCount, 6).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, 6) = 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

##########    ab hier Verschiebe Codes

'**   Move Test und Ziel Test funktionierren beide!!
'**   1. Variante über FSO System, zweite klappt auch.

Sub Move_Test()
Dim FSO As Object, f1 As Object

quelle = "G:\_Test A\Mappe B.xlsx"
Ziel = "G:\_Test B\Mappe Test B.xlsx"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set f1 = FSO.GetFile(quelle)
f1.Move (Ziel)

End Sub

Sub Ziel_Test_()
Dim quelle As String
Dim Ziel As String

quelle = "G:\_Test A\Mappe A.xlsx"
Ziel = "G:\_Test B\Mappe A.xlsx"
Name quelle As Ziel

End Sub

'###   Test 3 funktioniert leider NICHT !!
'###   Schade, verschiebt ganzen Ordner!!

Sub Test_3()
    Const PFAD_A As String = "G:\_Test A\"
    Const PFAD_B As String = "G:\_Test B\"
    
    Dim Datei As String
    
    Datei = Dir(PFAD_A, vbDirectory)
    Do While Datei <> vbNullString
'        If Left(Datei, 2) = "Ma" Then
        Name PFAD_A & Datei As PFAD_B & Datei
        Datei = Dir
'        End If
    Loop
    
End Sub