Hallo ch79, ich hatte nun Zeit mal zwei Dateien zu erstellen und das Makro zu testen. Es war noch ein Fehler meinerseits drin. Ich suchte in Spalte 3, du hast aber in der excel2 die KW's in Spalte 2 stehen.

Fehler ist behoben und hier das aktuelle.

Wenn Fehler auftreten, bitte die Zeile mitteilen, die dann gelb hinterlegt ist. Hilft allen bei der Fehlersuche.

Falls es dich nicht bekannt ist:
- Ansicht / Lokalfenster zeigt unten ein Fenster an, in der alle aktuellen Variablen mit enthaltenen Werten aufgelistet werden
- Mit F8 kann das Makro Schritt für Schritt analysiert werden

Gruß
Der TestGast

--- Makro ---

Option Explicit

Sub DatenKopieren()
    Dim intKW As Integer
    Dim strKW As String
    
    Dim varZeile As Variant
    
    Dim wsQuelle As Worksheet
    Set wsQuelle = ActiveSheet              'Muss ja das aktuelle Blatt sein, da mit Button gestartet
    
    Dim strZielDatei As String
    Dim strZielTabelle As String
    strZielDatei = "c:\temp\Mappe2.xlsx"    'Hier bitte Anpassen oder eigene Abfrage erstellen
    strZielTabelle = "Tabelle1"             'Hier bitte Anpassen oder eigene Abfrage erstellen
    
    Dim lngZielZeile As Long
    
    Dim wbZiel As Workbook
    Dim wsZiel As Worksheet
    
    'Zieldatei öffnen, oder wenn geöffnet übernehmen
    Set wbZiel = DateiÖffnen(strDateiname:=strZielDatei, UpdateLinks:=True, ReadOnly:=False)
    If wbZiel Is Nothing Then
        MsgBox "Datei nicht gefunden!", vbCritical + vbOKOnly, "Datei nicht gefunden"
        GoTo Aufräumen
    End If
    Set wsZiel = wbZiel.Worksheets(strZielTabelle)
    
    'Kalenderwoche aus Excel1 auslesen
    intKW = wsQuelle.Range("B41").Value
    strKW = "KW" & intKW
    
    'KWxx in Zieldatei suchen
    varZeile = Application.Match(strKW, wsZiel.Columns(2), 0)
    If VarType(varZeile) <> vbError Then
        lngZielZeile = Val(varZeile)
        Else
        MsgBox "Kalenderwoche " & strKW & " nicht gefunden", vbCritical + vbOKOnly, "KW nicht gefunden"
        GoTo Aufräumen
    End If
    
    'nächste freie Zelle suchen (in Spalte 2)
    Do While wsZiel.Cells(lngZielZeile, 2) <> ""
        lngZielZeile = lngZielZeile + 1
    Loop
    
    'Daten kopieren
    wsQuelle.Range("L66:U66").Copy Destination:=wsZiel.Cells(lngZielZeile, 2)
    
        
Aufräumen:
    'Aufräumen
    Set wbZiel = Nothing
    Set wsZiel = Nothing
    Set wsQuelle = Nothing
End Sub


Private Function DateiÖffnen( _
            ByVal strDateiname As String, _
            ByVal UpdateLinks As Boolean, _
            ByVal ReadOnly As Boolean) As Workbook
            
    Dim WB As Workbook
    Dim Pos As Long
    Dim DateiName As String
    
    Pos = InStrRev(strDateiname, "\", , vbTextCompare)
    If Pos = 0 Then Exit Function
    
    DateiName = Mid(strDateiname, Pos + 1)
    
    For Each WB In Application.Workbooks
        If WB.Name = DateiName Then
            Set DateiÖffnen = WB
            Exit Function
        End If
    Next WB
    
    On Error Resume Next
    Set DateiÖffnen = Workbooks.Open(strDateiname, UpdateLinks:=UpdateLinks, ReadOnly:=ReadOnly)
    On Error GoTo 0
End Function