Makroausführung braucht zu lange

Sub Daten_uebertragen()
 Debug.Print Now
 
 Dim i As Long, Zeile As Long, letzteZeile As Long
 Dim Arbeitsmappe As Workbook
 Dim Datenbasis As Worksheet, Ziel As Worksheet
 Dim ZelleKD_NR As Range, Bereich As Range
 Dim iName As Integer, iTel As Integer, iNr As Integer, iOrt As Integer, _
   iStrasse As Integer, iPLZ As Integer, iBranche As Integer, iKdNr As Integer
 
 Set Arbeitsmappe = ThisWorkbook
 Set Datenbasis = Arbeitsmappe.Worksheets("1. Update aus SAP")
 Set Ziel = Arbeitsmappe.Worksheets("Bestandstabelle")
 
 With Datenbasis
   For i = 1 To 8
     Select Case .Cells(1, i)
       Case "Branchen_Art": iBranche = i
       Case "Firma_Name": iName = i
       Case "KD_NR": iKdNr = i
       Case "PLZ": iPLZ = i
       Case "Ort": iOrt = i
       Case "PHONE_NR": iTel = i
       Case "Straße": iStrasse = i
       Case "NR": iNr = i
     End Select
   Next i
 End With
 
 
 With Datenbasis
   letzteZeile = .Cells(Rows.Count, iKdNr).End(xlUp).Row
   Set Bereich = .Range(.Cells(2, iKdNr), .Cells(letzteZeile, iKdNr))
 End With
 
 For i = 2 To Ziel.Range("C" & Rows.Count).End(xlUp).Row
     With Datenbasis
         Set ZelleKD_NR = Bereich.Find(Ziel.Range("C" & i).Value, LookIn:=xlValues, lookat:=xlWhole)
         If Not ZelleKD_NR Is Nothing Then
             Ziel.Range("A" & i).Value = .Cells(ZelleKD_NR.Row, iBranche).Value
             Ziel.Range("B" & i).Value = .Cells(ZelleKD_NR.Row, iName).Value
             Ziel.Range("D" & i).Value = .Cells(ZelleKD_NR.Row, iPLZ).Value
             Ziel.Range("E" & i).Value = .Cells(ZelleKD_NR.Row, iOrt).Value
             Ziel.Range("F" & i).Value = .Cells(ZelleKD_NR.Row, iStrasse).Value
             Ziel.Range("G" & i).Value = .Cells(ZelleKD_NR.Row, iNr).Value
             Ziel.Range("H" & i).Value = .Cells(ZelleKD_NR.Row, iTel).Value
             Set ZelleKD_NR = Nothing
         End If
     End With
 Next i
 
 Debug.Print Now
 End Sub