Hallo

ich habe das Ordner auflisten Programm noch mal geändert, Spalten verschoben für eine Suchlauf. Die Eingabe der Ordnerpfad ist Zelle C1 und G1

Neu ist ein Suchlauf der aus Spalte C in der Spalte G nach relevanten Ordnern sucht und den Ordnerpfad des Zielordner in Spalte D anzeigt.

Wenn das alles einwandfrei klappt, und du damit zurecht kommst, kann ich ein drittes Makro für das verschieben schreiben. Weil ich deine Datei nicht auf dem Rechner habe und auch keine Beispieldatei kann ich nicht prüfen ob mit deinen Daten alles richtig läuft. Das musst du bitte selbst testen.

Die Makros kannst du über normale CommandButton starten und das Makro direkt zuweisen. Bei AktiveX Steuerelemente geht das Nicht!!

Für heute genug getan ...   Morgen ist auch noch ein Tag.

mfg  Nobody

Option Explicit
Dim lngCount As Long

'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

########    Suchlauf nach Zielordnern

Option Explicit
Dim AC As Range, lz1 As Long
Dim Adr1 As String, rFind As Range

Sub Ordner_suchen()
Dim SuName As String, n, Txt As String
With ThisWorkbook.Worksheets("Tabelle4")
     .Range("E4:E1000").Clear
      lz1 = .Cells(Rows.Count, 3).End(xlUp).Row
    
      For Each AC In .Range("C5:C" & lz1)
         If AC.Value = Empty Or InStr(AC, ":") Then GoTo nx
         SuName = Left(AC, InStrRev(AC, ".") - 1)
         Set rFind = .Columns(7).Find(What:=SuName, After:=[g5], LookIn:=xlFormulas, LookAt:= _
             xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
    
         If Not rFind Is Nothing Then
            Adr1 = rFind.Address: n = 0
            Do
               If InStr(rFind, ":") Then
                  Txt = AC.Offset(0, 1)  'dopp. Test
                  If Txt <> "" Then Txt = ", " & Txt
                  AC.Offset(0, 1) = rFind.Value & Txt
                  n = n + 1
               End If
               Set rFind = .Columns(7).FindNext(rFind)
            Loop Until rFind.Address = Adr1
            If n > 1 Then AC.Offset(0, 1).Font.ColorIndex = 3
nx:      End If
      Next AC
End With
End Sub