Code sehr langsam

Sub Tabellenblatt_Aufgaben_Bewertung_Kopieren_alle()
Dim Index As Integer            'Zellennummer auf Seite
Dim Nummer As String            'Nummer Bsp. 31-02
Dim Name As String              'Name
Dim Nachname As String          'Nachname der Person
Dim Vorname As String           'Vorname der Person
Dim Kandidatennummer As String  'Kandidatennummer Bsp. 1
Dim Blattname As String         'Blattname der Originaldatei
'Deklaration Masse
Dim Ausführung As String
Dim Rückwand As String
Dim Frontholzstruktur As String
Dim Höhe As Integer
Dim Breite As Integer
Dim Tiefe As Integer
Dim Konstruktion As String
Dim Mass As Integer
Dim Elementmass As Integer
Dim Bildnummer As Integer
'Dim Bild As Picture
msgbox "Bitte haben Sie ein wenig Geduld, sämtliche Blätter werden nun erstellt."
'Nummer = Tabelle1.ComboBox2.Value
'Initialisieren der Variablen
Index = 4       'Start auf Zeile 4
Nachname = ""   'Leer
Vorname = ""
Kandidatennummer = ""
Blattname = "Kandidaten"
'Index2 = Bildnummer
Call Löschen_Tabellenblaetter_ausser_originale              'Rufe Makro "Lö _
schen_Tabellenblaetter_ausser_originale" auf und führe aus.
Sheets("Kandidaten").Select
With Application
.ScreenUpdating = False                     'Ab hier wird der Screen nicht mehr  _
aktualisiert = kein Flackern
.Calculation = xlCalculationManual          'Hier wird die automatische Berechung  _
ausgeschaltet Achtung: Diese muss unten wieder eingeschaltet werden
.EnableEvents = False                       'Ab hier werden PopUp's etc. unterdrü _
ckt
End With
On Error GoTo ENDE:
'Suche Spalte mit Nummer
Do Until Range("B" & Index) = "" Or Range("B" & Index) = Nummer         'Mache bis, Finde  _
Spalte B und Index leer ist, oder bis die Nummer gefunden ist
Nummer = Range("B" & Index)
'Wenn Spalte gefunden dann Variablen Auslesen und im System ablegen
'Variablen zuweisen von "Hauptblatt"
Nummer = Sheets("Kandidaten").Range("B" & Index)             'Kopiere und weise  _
Zellinhalt "Inhalt" als Nummer aus dem Blatt "Hauptblatt" in der Spalte B
Nachname = Sheets("Kandidaten").Range("C" & Index)           'Kopiere und weise  _
Zellinhalt "Nachname" als Nummer aus dem Blatt "Hauptblatt" in der Spalte B
Vorname = Sheets("Kandidaten").Range("D" & Index)            'Kopiere und weise  _
Zellinhalt "Vorname" als Nummer aus dem Blatt "Hauptblatt" in der Spalte B
Ausführung = Sheets("Kandidaten").Range("E" & Index)
Rückwand = Sheets("Kandidaten").Range("F" & Index)
Frontholzstruktur = Sheets("Kandidaten").Range("G" & Index)
Höhe = Sheets("Kandidaten").Range("H" & Index)
Breite = Sheets("Kandidaten").Range("I" & Index)
Tiefe = Sheets("Kandidaten").Range("J" & Index)
Konstruktion = Sheets("Kandidaten").Range("L" & Index)
Mass = Sheets("Kandidaten").Range("M" & Index)
Bildnummer = Sheets("Kandidaten").Range("K" & Index)
'            Bild = Sheets("Bilder").Range("A" & Index2)
'Elementmass = Scheets("Kandidaten").Range("H" & Index) - Scheets("Kandidaten"). _
Range("M" & Index)
'Vorlage aktivieren
Worksheets("Aufgabenstellung").Visible = True                                      ' _
Blendet Blatt "Aufgabenstellung" ein
'Neues Sheet erstellen mit Name des Kanididaten
ErrorFlag = True
'On Error GoTo errorhandler1                                                                 _
'Im Falle einses Fehler gehe nach...errorhandler1
ActiveWorkbook.Sheets("Aufgabenstellung").Copy after:=Worksheets(Worksheets.Count) ' _
neues Blatt am Ende der Tabelle
ActiveWorkbook.Sheets("Aufgabenstellung (2)").Name = Nachname + " " + Vorname + " " + " _
Aufgabe"
''        Sheets(Worksheets.Count).Name = Nachname + " " + Vorname + " " + "Aufgabe"
ErrorFlag = False
Application.DisplayAlerts = False
''errorhandler1:                                                                             _
'Programm wird bis zu diesem Punkt übersprungen
''    If ErrorFlag Then                                                                      _
'Wenn ein Fehler auftritt
''        Application.DisplayAlerts = False                                                  _
'Popup-Fehlerfenster = false = deaktivieren
''        Sheets(Worksheets.Count).Delete                                                    _
'Löscht das erstellte Sheet
''        'Sheets("Aufgabenstellung (2)").Delete
''        Application.DisplayAlerts = True                                                   _
'Popup-Fehlerfenster = true = aktiviert für "spätere Fehlermeldungen"
''    End If                                                                                 _
'Schluss mit Wenn
'Vorlage deaktivieren
Worksheets("Aufgabenstellung").Visible = False                                           _
'Blendet "Aufgabenstellung" aus
'Sheet ausfüllen (Achtung: Der Sheets-Name muss wie oben im "Namen ändern" angegeben  _
werden, ansonsten haben wir einen Syntaxfehler)
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("N9").Value = Nummer            _
'Füllt den Inhalt Nummer in den neuen Kandidat auf der entsprechnenden Zelle
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("E9") = Nachname
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("E8") = Vorname
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("H31") = Ausführung
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("H32") = Rückwand
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("H34") = Frontholzstruktur
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("D39") = Konstruktion
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("G46") = Höhe
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("G47") = Breite
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("G48") = Tiefe
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("C36") = Bildnummer
Sheets(Nachname + " " + Vorname + " " + "Aufgabe").Range("C36") = Bildnummer
'Hier wird das Bild angepasst
ActiveSheet.Shapes.Range(Array("Picture 7")).Select
Selection.ShapeRange.Height = 368.5039370079
'-------------Bewertung, passend zum Kandidaten-----------------------
'Vorlage aktivieren
Worksheets("Bewertung").Visible = True                                      'Blendet  _
Blatt "Bewertung" ein
'Neues Sheet erstellen mit Name des Kanididaten
'        ErrorFlag = False
'On Error GoTo errorhandler1                                                                 _
'Im Falle einses Fehler gehe nach...errorhandler1
ActiveWorkbook.Sheets("Bewertung").Copy after:=Worksheets(Worksheets.Count) 'neues  _
Blatt am Ende der Tabelle
ActiveWorkbook.Sheets("Bewertung (2)").Name = Nachname + " " + Vorname + " " + " _
Bewertung"
''        Sheets(Worksheets.Count).Name = Nachname + " " + Vorname + " " + "Bewertung"
'        ErrorFlag = False
Worksheets("Bewertung").Visible = False                              'Blendet Blatt " _
Bewertung" aus
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("E6").Value = Nummer          _
'Füllt den Inhalt Nummer in den neuen Kandidat auf der entsprechnenden Zelle
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("C5").Value = Nachname
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("C6").Value = Vorname
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("D19").Value = Konstruktion
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("D22").Value = Ausführung
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("E22").Value = Rückwand
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("D36").Value = Höhe
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("D37").Value = Breite
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("D38").Value = Tiefe
Sheets(Nachname + " " + Vorname + " " + "Bewertung").Range("D39").Value = Elementmass
'Hier wird das Bild angepasst
ActiveSheet.Shapes.Range(Array("Picture 3")).Select
Selection.ShapeRange.Height = 102.0472440945
Application.DisplayAlerts = True
'Vorlage deaktivieren
Worksheets("Bewertung").Visible = False                                                  _
'Blendet "Bewertung" aus
'Sheets(Nachname + " " + Vorname + " " + "Bankbesch.").Range("A1").Select                _
'Öffnet gleich den neu erstellten Kandidaten
Sheets("Kandidaten").Select
Index = Index + 1           'Fahre im Index immer eine Zeile weiter
Loop       'Diese Prozedur wiederholen solange "Bedinungen" bei "Do Until" gewährleistet  _
werden.
ENDE:
With Application
.ScreenUpdating = True                      'Bildschirm wird wieder aktiviert
.Calculation = xlCalculationAutomatic       'Automatisches Rechnen in Excel
.EnableEvents = True                        'PopUp's wieder zulässig
End With
End Sub