Hallo,
teste mal:
Option Explicit
Public Sub EintraegeKopieren_Jahre()
Dim ws As Worksheet
Dim wsTarget As Worksheet
Dim i As Long, j As Long, lr As Long, lrTarget As Long
Dim Var1 As String
Set wsTarget = Sheets("Gesamtliste")
Erneut:
'weiter bei Fehler
On Error Resume Next
'Inputbox für Eingabe des Jahres
Var1 = InputBox("Bitte ein Jahr eingeben, Format: JJJJ", "Jahr auswählen")
'Prüfen ob eine Eingabe erfolgt ist
If Var1 = vbNullString Then Exit Sub
'Prüfen ob eine 4-stellige Zahl eingegeben wurde
If Not IsNumeric(CLng(Var1)) Or Len(Var1) <> 4 Then
MsgBox "Nur 4-stellige Zahlenwerte zuässig."
'Fehler zurücksetzen
On Error GoTo 0
'bei Fehleingabe zurück zur Inputbox
GoTo Erneut
Exit Sub
Else
'Schleife über die Blätter
For i = 3 To 53
Set ws = Sheets(i)
'Letzte Zeile im Sheet(Gesamtliste) ermitteln
lrTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row
With ws
'Letzte Zeile im jeweiligen Sheet ermitteln
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Prüfen, ob ab Zeile 20 Werte im jeweiligen Sheet stehen
If lr >= 20 Then
'Durchlauf aller Zeilen ab Zeile 20 bis zur letzten verwendeten Zeile
For j = 20 To lr
'Prüfen ob Jahr aus Inputbox mit Jahr aus Zelle übereinstimmg
If Year(.Cells(j, 7)) = CLng(Var1) Then
'wenn ja dann Daten kopieren
.Range(.Cells(j, 1), .Cells(j, 18)).Copy wsTarget.Cells(lrTarget + 1, 1)
'Zähler für Zielzeile hochsetzen
lrTarget = lrTarget + 1
End If
Next j
End If
End With
Next i
End If
'Rangevariable leeren
Set wsTarget = Nothing
Set ws = Nothing
'Fehler zurücksetzen
On Error GoTo 0
End Sub
Gruß Werner
|