Sub DoIt()
Const zvPfad As String = "C:\Warenkorb\Zu_Verkaufen\"
Const zkPfad As String = "C:\Warenkorb\Zu_Kaufen\"
Const vPfad As String = "C:\Warenkorb\Verkauft\"
Const gPfad As String = "C:\Warenkorb\Gekauft\"
Dim f As String
Dim arr() As Variant, strarr() As String
Dim x As Long
arr = ActiveSheet.UsedRange.Columns(1).Resize(, 2).Value
ReDim strarr(0 To UBound(arr, 1) - 1)
For x = LBound(arr, 1) To UBound(arr, 1)
Select Case arr(x, 2)
Case "Gekauft"
ChDir zkPfad
If Len(Dir(Left(arr(x, 1), 10) & "*.*")) > 0 Then
On Error Resume Next
Name zkPfad & Dir(Left(arr(x, 1), 10) & "*.*") As _
gPfad & Dir(Left(arr(x, 1), 10) & "*.*")
If Err.Number = 0 Then _
strarr(x - 1) = arr(x, 1) & " - " & "nach " & gPfad
On Error GoTo 0
End If
Case "Verkauft"
ChDir zvPfad
If Len(Dir(Left(arr(x, 1), 10) & "*.*")) > 0 Then
On Error Resume Next
Name zvPfad & Dir(Left(arr(x, 1), 10) & "*.*") As _
vPfad & Dir(Left(arr(x, 1), 10) & "*.*")
If Err.Number = 0 Then _
strarr(x - 1) = arr(x, 1) & " - " & "nach " & vPfad
On Error GoTo 0
End If
End Select
Next x
MsgBox Join(strarr, vbLf)
End Sub