Files in neuen Folder kopieren

Sub Copy_Files_with_new_name()
Dim wb                      As Workbook
Dim wbThis                  As Workbook     'workbook where range and path is stored
Dim wbTarget                As Workbook     'workbook from where the data is to be copied from, (aka Overnights file)
Dim Path1                   As String       'path in which the files are which shall be opened
Dim Path2                   As String       'path in which new files shall be safed
Dim NewFileName             As String       'neuer Speichername
Dim SaveNameSEC_CC          As String       'Save Name SEC&CC
Dim SaveNamePeriod          As String       'Save Name Period
Dim fname                   As String
Dim Dateiname               As String
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
'.Application.StatusBar = "Zur Zeit wird das Makro ausgeführt"
End With
Set wbThis = ActiveWorkbook                 'set to the current active workbook (the source book, the Master!)
Path1 = sht_makro.Range("Path1").Value                            ' Path wo Files gespeichert sind
Path2 = sht_makro.Range("Path2").Value                            ' Path wo Files gespeichert sind
SaveNamePeriod = sht_makro.Range("B7").Value                         ' Cellname Periode - (currently in cell B7 in File Makro)
SaveNameSEC_CC = sht_makro.Range("b8").Value
'Öffnet die Files des "openPath"
fname = Dir(Path1)
Do While fname  ""
Set wbTarget = Workbooks.Open(Filename:=Path1 & fname)
Dateiname = wbTarget.Name
NewFileName = wbThis.Sheets("Sheet1").Range("b7").Value
wbTarget.SaveAs Filename:=NewFileName & Dateiname, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wbTarget.Close
fname = (Dir)
Loop
'dann wieder zum Makrofile wechseln
wbThis.Activate
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End Sub