Option Explicit
Public Sub now_tested()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim objCell As Range
Dim astrNames() As String
Dim strSourcePath As String, strDestinationPath As String
Dim ialngIndex As Long
strSourcePath = "C:\Bestellungen"
strDestinationPath = "C:\Versand"
Set objFSO = CreateObject(Class:="Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strSourcePath)
For Each objFile In objFolder.Files
With Workbooks("TwsActiveX.xls").Worksheets("Executions")
For Each objCell In .Range(.Cells(11, 12), .Cells(100, 12))
With objCell
If .Value = vbNullString Then
Exit For
ElseIf objFile.Name Like "*" & .Value & "*" And .Offset(0, 5).Value = "SLD" Then
ReDim Preserve astrNames(ialngIndex) As String
astrNames(ialngIndex) = objFile.Name
ialngIndex = ialngIndex + 1
Exit For
End If
End With
Next
End With
Next
For ialngIndex = 0 To UBound(astrNames)
Call objFSO.MoveFile(strSourcePath & "\" & astrNames(ialngIndex), _
strDestinationPath & "\" & astrNames(ialngIndex))
Next
Set objCell = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
End Sub