Von einer Spalte werden vorgegebene Verzeichnisse und Dateien wie (#EXCEL) aber ohne # in einer
zweiten Spalte in der Verzeichnisliste gesucht und wenn gefunden in die ersten Spalte deren #EXCEL
Verzeichniss verschoben.

Bei der Zeile --- fso.MoveFolder Range("H8"), Range("H9") ' Zugriff verweigert !!

--------------- das Programm mit Zugriff verweigert !!----------
Sub MoveFilesAndDirectories()
Dim ws As Worksheet
Dim lastRow As Long
Dim searchRange As Range
Dim cell As Range
Dim searchText As String
Dim destinationFolder As String
Dim SourceFolder As String
Dim sourceFile As String
Dim fso As Object ' FileSystemObject
Dim file As Object ' File or Folder ' Set the worksheet where the data is located
Set ws = ThisWorkbook.ActiveSheet '("Sheet1") ' Replace "Sheet1" with the actual sheet name
Range("C7") = 22: Range("I22").Select ' Set the range to search in columns H and I, starting from row 22
lastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
Set searchRange = ws.Range("G22:I" & lastRow)
Range("H7") = searchRange
Range("C8") = lastRow
Set fso = CreateObject("Scripting.FileSystemObject") ' Create the FileSystemObject
For Each cell In searchRange.Rows ' Loop through each row
searchText = cell.Cells(1, 2).value ' Get the search text from column H
Range("H10") = searchText
destinationFolder = cell.Cells(1, 1).value ' Get the destination folder from column G
Range("H9") = destinationFolder
SourceFolder = cell.Cells(1, 3).value ' Get the source folder/file from column I
Range("H8") = Left(SourceFolder, Len(SourceFolder) - 1)
If fso.FolderExists(SourceFolder) Or fso.FileExists(SourceFolder) Then ' Check if the source folder/file exists
If InStr(1, Range("H8"), Range("H10"), vbTextCompare) > 0 Then ' Check if the search text is found in the source folder/file name
' If InStr(1, sourceFolder, searchText, vbTextCompare) > 0 Then
' Move the source folder/file to the destination folder
fso.MoveFolder Range("H8"), Range("H9") ' Zugriff verweigert !!
' fso.MoveFolder sourceFolder, destinationFolder
End If
End If
Next cell
Set fso = Nothing ' Clean up objects
Set searchRange = Nothing
Set ws = Nothing
End Sub