Option Explicit
Sub DatenKopieren()
Dim intKW As Integer
Dim strKW As String
Dim varZeile As Variant
Dim wsQuelle As Worksheet
Set wsQuelle = ActiveSheet
Dim strZielDatei As String
Dim strZielTabelle As String
strZielDatei = "c:\temp\Mappe2.xlsx"
strZielTabelle = "Tabelle1"
Dim lngZielZeile As Long
Dim wbZiel As Workbook
Dim wsZiel As Worksheet
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)
intKW = wsQuelle.Range("B41").Value
strKW = "KW" & intKW
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
Do While wsZiel.Cells(lngZielZeile, 2) <> ""
lngZielZeile = lngZielZeile + 1
Loop
wsQuelle.Range("L66:U66").Copy Destination:=wsZiel.Cells(lngZielZeile, 2)
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