Hallo

mir sind heute doch noch in zwei Modulen Fehler aufgefallen, die sich auf die With Klammer beziehen. Da fehlen bei einigen Cells und Range der Punkt.

Zur Vorishct lade ich die berichtigten Makros noch mal hoch. In allen Modulen findest du den Code:   With ThisWorkbook.Worksheets("Tabelle4")

In deiner Datei kannst du das in allen Modulen auf deine eigene Tabelle umbenennen.

mfg  Nobody

Modul 1   Auflisten

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("Tabelle4")
    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("Tabelle4")
    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 3   Verschieben

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