Schleife mit speichern

Sub speicher()
dim current as worksheet
dim str as string
dim I as integer
For Each current In Worksheets
Sheets("Duplikat").Activate
For I = 1 To Sheets("Duplikat").Cells(Rows.Count, 1).End(xlUp).Row
If Sheets("Duplikat").Range("A" & I).Value = current.name Then
current.Activate
current.Copy
Const LW = "D:\"
Const Pfad = "D:\Users\Name\Desktop\Qualitätsprüfung"
str = current.name
ChDrive LW
ChDir Pfad
ActiveWorkbook.SaveAs Filename:=str, FileFormat:=xlOpenXMLWorkbook
End If
Next I
Next current
End Sub