VBA - Dateien von allen Namen in A:A anlegen

Option Explicit
Sub Speichern()
Dim Start As Long
Dim LzB1 As Long
Dim LzB2 As Long
Dim StrName As String
Dim i As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.Cursor = xlWait
End With
Start = 6
LzB1 = Application.Max(6, Cells(Rows.Count, 1).End(xlUp).Row)
Columns(10).ClearContents
Range(Cells(Start, 1), Cells(LzB1, 1)).Copy
Cells(Start, 10).PasteSpecial xlPasteValues 'Spalte 10
Range(Cells(Start, 10), Cells(LzB1, 10)).RemoveDuplicates Columns:=1, Header:=xlNo ' Spalte  _
10
LzB2 = Application.Max(6, Cells(Rows.Count, 10).End(xlUp).Row) 'Spalte 10
For i = 1 To LzB2 - 5
StrName = ThisWorkbook.Path & "\" & Cells(Start - 1 + i, 10)
ActiveWorkbook.SaveAs StrName
Next i
With Application
.StatusBar = False
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.Cursor = xlDefault
End With
Application.DisplayAlerts = False
ThisWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
End Sub