trotz vieler Anregungen stehe ich jetzt richtig auf dem Schlauch!
Ich poste mal den gesamten Code.
Mein Ziel ist es, dass nach der Übertragung in die neuen Tabellenblätter nur gefüllte Zellen übertragen werden. In der gesamten Range stehen zur Zeit auch nach dem letzten Eintrag noch Leerzeilen. Diese werden im Moment noch mit übertragen, was in den Zieltabellen zu Müll führt.
Sub DatenUebertrag()
Dim sFile As String, rng1 As Range, rng2 As Range, Zeilenzahl As Integer, intRow As Integer
Application.ScreenUpdating = False
sFile = Range("E33") & (".xls")
If Dir(sFile) = "" Then
MsgBox "Kann eine Datei mit dem angegebenen Pfad: " & Range("E33") & " nicht finden!" _
& vbLf & "Bitte überprüfen Sie den Namen und starten die Übertragung danach erneut."
End
Else
Workbooks.Open Filename:=sFile
End If
Set rng1 = Worksheets("Tabelle1").Range("A1:D300")
Set rng2 = Worksheets("Tabelle1").Range("E1:H300")
Workbooks("Basis.xls").Activate
Worksheets("Kunden").Activate
ActiveSheet.Unprotect
intRow = 1
Do While Left(Cells(intRow, 1), 7) <> ""
intRow = intRow + 1
Loop
rng1.Copy
Range(Cells(intRow, 4).Address).PasteSpecial Paste:=xlValues
ActiveSheet.Protect
Worksheets("Mitarbeiter").Activate
ActiveSheet.Unprotect
intRow = 1
Do While Left(Cells(intRow, 1), 7) <> ""
intRow = intRow + 1
Loop
rng2.Copy
Range(Cells(intRow, 5).Address).PasteSpecial Paste:=xlValues
ActiveSheet.Protect
Application.ScreenUpdating = True
Debug.Print MsgBox("Die Monatswerte wurden erfolgreich übertragen", 0, "Datenübertragung")
Kill sFile
End Sub
Darf ich Euch hierzu deshalb noch einmal bemühen?
Gruß
Wolfgang