Fehler beim kopieren in neue Tabelle

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
On Error Resume Next
Dim TabAnlegen As Boolean
Dim VorhTab                 'Abfrage ob Tab. vorhanden
Dim ZI                      'ZellInhalt Quelltabelle
Dim ShQ                     'Quelltabelle mit Eintragungen
Dim ShVL                    'Tabellenvorlage
Dim iRow                    'letzte Zeile
Set ShQ = Sheets("Quelle")
Set ShVL = Sheets("Vorlage")
ZI = ShQ.Cells(Target.Row, 2).Value
iRow = Sheets(ZI).Cells(Rows.Count, 3).End(xlUp).Row + 1
If ZI <> "" Then TabAnlegen = False
For Each VorhTab In ActiveWorkbook.Sheets
If VorhTab.Name = ZI Then
'Quellinhalt kopieren wenn Tabelle vorhanden
Sheets(ZI).Cells(iRow, 3) = ShQ.Cells(Target.Row, 3)
TabAnlegen = True
Exit For
End If
Next
'Tabelle anlegen wenn nicht vorhanden
If TabAnlegen = False Then
ShVL.Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = ZI
'Quellinhalt in erstellte Tabelle kopieren
Sheets(ZI).Cells(iRow, 3) = ShQ.Cells(Target.Row, 3)   'Fehler <<<<
'Sheets(ZI).Cells(3, 3) = ShQ.Cells(Target.Row, 3)     'OK <<<<<<<<
End If
ShQ.Activate
End Sub