VBA-Hilfe

Private Sub CommandButton1_Click()
On Error GoTo Fehler
Dim WB1, WB2, ZielTB, TB1, TB2, ZielRNG As Range
Dim Pfad As String, KW As Integer, Datei As String, Ext As String
Dim LR As Long, LR2 As Long, i As Integer
Set WB1 = ActiveWorkbook
Set ZielTB = WB1.Sheets("Import")
' anpassen***
Set ZielRNG = ZielTB.Range("L3") ' *** geändert ***
Ext = ".xlsx" ' Ende anpassen***
Pfad = Sheets("Stammdaten").Range("B3").Value
KW = WorksheetFunction.WeekNum(Date, 11) - 1
KW = InputBox("Eingabe Kalenderwoche", "Verzeichnisauswahl", KW)
For i = 1 To 1
Datei = Pfad & "\KW " & KW & "\Doublecheck"
Workbooks.Open Filename:=Datei
Set WB2 = ActiveWorkbook
Set TB1 = WB2.Sheets("Quality + Pick & Pack")
Set TB2 = WB2.Sheets("Quality + Pick & Pack")
LR = ZielTB.Cells(ZielTB.Rows.Count, "A").End(xlUp).Row + 1 'erste Freie Zeile Spalte A
LR2 = TB1.Cells(TB1.Rows.Count, "F").End(xlUp).Row 'letzte Zeile Spalte A
TB1.Range(TB1.Cells(2, 1), TB1.Cells(LR2, 1)).Copy ZielTB.Cells(LR, 1)
TB1.Range(TB1.Cells(2, 6), TB1.Cells(LR2, 6)).Copy ZielTB.Cells(LR, 6) ' *** neu: F ***
'TB2.Range("L2:L6").Copy ZielRNG ' !!!wird immer wieder überschrieben
ZielRNG.Resize(5).Value = TB2.Range("L2:L6").Value  ' *** von WOHER? ***
' so wird der Zielbereich von mal zu mal
' um 2 Spalten versetzt:
Set ZielRNG = ZielRNG.Offset(, 2) ' *** geändert ***
WB2.Close savechanges:=False
Next
Err.Clear
Fehler:
If Err.Number  0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub