Sub copy_KWsheet()
'** Kopieren des ersten Sheets aus der angegebenen KW-Arbeitsmappe
'** Dimensionierung der Variabeln
Dim strPath As String
'** Vorgaben definieren
Set wbact = ThisWorkbook
Set wsmas = ThisWorkbook.Sheets("Master")
'** Vorbereiten
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'** Durchlaufen der Tabellen (KW) - Liste
For a = 9 To 26
'** Nur ausführen, wenn ein Tabellenblattname vorhanden ist
If wsmas.Cells(a, 2).Value <> "" Then
'** Pfad zusammenbauen
strPath = wsmas.Range("B6").Value & wsmas.Cells(a, 2).Value
'** Blattnamen auslesen
wsname = Left(wsmas.Cells(a, 2).Value, InStr(1, wsmas.Cells(a, 2).Value, ".") - 1)
'** Prüfen, ob das Sheet bereits vorhanden ist, wenn ja, vorher löschen
Dim blatt As Object
For Each blatt In Sheets
If blatt.Name = wsname Then
Application.DisplayAlerts = False
blatt.Delete
Application.DisplayAlerts = True
End If
Next blatt
'** Position des neuen Blattes ermitteln
i = Worksheets.Count
'** KW-Datei öffnen
Workbooks.Open strPath
'** Blatt kopieren
With ActiveWorkbook
.Sheets(1).Select
.Sheets(1).Copy After:=Workbooks(wbact.Name).Sheets(i)
.Close savechanges:=True
End With
'** Namen für neues Sheet setzen
Workbooks(wbact.Name).Activate
ActiveSheet.Name = wsname
End If
Next a
'** Ursprungszustand herstellen
wsmas.Select
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
'** Hinweis
MsgBox "Die Dateien wurden korrekt importiert!", vbInformation, "Hinweis"
End Sub