Erweiterung der Kopierfunktion

Public Sub AA_Adresse_in_Rechnungs_Datenbank_kopieren()
Dim wksQUELLE As Worksheet            'Quell-Worksheet
Dim wksZIEL As Worksheet                  'Ziel-Worksheet
Dim wkbZIEL As Workbook, wkbQUELLE As Workbook
Dim rngZIEL As Range
Dim strSUCH As String
Const cstr_wkbQUELLE As String = "Datenbank.xlsm"
Const cstr_wksQUELLE As String = "Daten"
Const getStrPassWort = "passi#"
Set wkbQUELLE = ActiveWorkbook
Set wksQUELLE = ActiveSheet
Application.ScreenUpdating = False
On Error Resume Next
Set wkbZIEL = Workbooks(cstr_wkbQUELLE)
On Error GoTo 0
If wkbZIEL Is Nothing Then
Set wkbZIEL = Workbooks.Open("D:\" & cstr_wkbQUELLE)
End If
'Worksheet-Variable setzen
Set wksZIEL = wkbZIEL.Worksheets(cstr_wksQUELLE)
Begriff suchen
strSUCH = wksQuelle.Range("C13")
Set rngZiel = wksZiel.Range("B:B").Find(What:=strSUCH, After:=wksZIEL.Range("B3"), LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
'Suchergebnis prüfen: strSUCH nicht gefunden: Am Ende Anfügen
If rngZIEL Is Nothing Then
Set rngZIEL = wksZIEL.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
End If
'übertragen
wksZIEL.Unprotect (getStrPassWort)
wksQUELLE.Range("C12:C17").Copy
rngZIEL.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Dim i As Long
With Application
.EnableEvents = False      'Ereignisse ausschalten
End With
With Application
.EnableEvents = True
End With
wksZIEL.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:=getStrPassWort
Application.CutCopyMode = False
wkbQUELLE.Activate
wksQUELLE.Activate
wksQUELLE.Range("C12").Select
MsgBox "Die Adresse wurde erfolgreich kopiert !", _
48, "   Hinweis für " & Application.UserName
Application.ScreenUpdating = True
End Sub