Option Explicit
Sub kopieren()
Const strSOURCE As String = "Daten"
Const strTARGET As String = "Versuch"
Dim lngLaufZahl As Long
Dim wsSOURCE As Excel.Worksheet
Dim wsTARGET As Excel.Worksheet
On Error Resume Next
For lngLaufZahl = 1 To ThisWorkbook.Sheets.Count / 2 + 1
Set wsSOURCE = ThisWorkbook.Sheets(strSOURCE & CStr(lngLaufZahl))
Set wsTARGET = ThisWorkbook.Sheets(strTARGET & CStr(lngLaufZahl))
If wsSOURCE Is Nothing Or wsTARGET Is Nothing Then
Err.Clear
GoTo Fehler
Else
wsSOURCE.Range("$A$1:$F$500").Copy wsTARGET.Range("$A$1")
wsTARGET.Range("$A$1").Select
If Not wsSOURCE Is Nothing Then Set wsSOURCE = Nothing
If Not wsTARGET Is Nothing Then Set wsTARGET = Nothing
End If
Next lngLaufZahl
Exit Sub
Fehler:
If wsSOURCE Is Nothing Then
MsgBox "Keine Datenquelle """ & strSOURCE & CStr(lngLaufZahl) & """ gefunden. Programm wird beendet.", vbCritical, "Fehler..."
If Not wsTARGET Is Nothing Then Set wsTARGET = Nothing
ElseIf wsTARGET Is Nothing Then
MsgBox "Keine Datenziel """ & strTARGET & CStr(lngLaufZahl) & """gefunden. Programm wird beendet.", vbCritical, "Fehler..."
If Not wsSOURCE Is Nothing Then Set wsSOURCE = Nothing
End If
End Sub