Thema: Prüfung in Array? | Herbers Excel-Forum

Guten Morgen allerseits
mit folgendem Makro prüfe ich eine Spalte (ca. 50.000 Zeilen) auf ein gültiges Datum. Einziges Manko, das Makro läuft lange, da es ja auf ca. 50.000 Zellen zugreifen muß. Gibt es eine Möglichkeit, das ganze in ein Array zu packen und dann abzuarbeiten? Wenn ja, wie?
Sub DatumPrüf()
Dim lz As Long, Akt As String, i As Long, a, b
Akt = ThisWorkbook.Name
DatPR = False
With ActiveSheet
lz = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 2 To lz
a = IsDate(.Cells(i, 4))
If a Then
If IsDate(.Cells(i, 4)) And Year(.Cells(i, 4)) >= 1980 And Year(.Cells(i, 4)) < 2020 Then
Else
.Cells(i, 5) = "Datum kleiner 1980 oder größer 2020"
End If
Else
.Cells(i, 5) = "kein Datum"
End If
Next
If Application.CountA(.Range(.Cells(2, 5), .Cells(lz, 5))) > 0 Then
.Range("E1").AutoFilter Field:=5, Criteria1:="<>"
DatPR = True
End If
Kann mir bitte jemand helfen?
DANKE und einen schönen Tag
Petra

Hi Petra,
vielleicht ist das hier schneller:

Option Explicit   ' IMMER ZU EMPFEHLEN
Sub DatumPrüf2()
Dim lngZ As Long
With ActiveSheet
lngZ = .Cells(.Rows.Count, 4).End(xlUp).Row
With .Cells(2, 5).Resize(lngZ - 1)
.Formula = _
"=IF(ISBLANK(D2)+ISERROR(DAY(D2))>0,""kein Datum""," & _
"IF((YEAR(D2)<=1980)+(YEAR(D2)>2020)>0," & _
"""Datum kleiner 1980 oder größer 2020"",""""))"
.Formula = .Value
End With
If Application.CountA(.Range(.Cells(2, 5), .Cells(lngZ, 5))) > 0 Then
.Range("E1").AutoFilter Field:=5, Criteria1:="<>"
End If
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

HAllo Petra
Ich habs mal versucht umzusetzen.
Teste mal selber:

ransi

Hi Ransi,
so geht es etwa in der halben Zeit:

Sub DatumPrüf4()
Dim lz As Long, I As Long, arrD, arrE() As String
With ActiveSheet
lz = .Cells(.Rows.Count, 4).End(xlUp).Row
arrD = .Range("D2:D" & lz)
ReDim arrE(1 To lz - 1)
For I = 1 To lz - 1
If IsDate(arrD(I, 1)) Then
Select Case Year(arrD(I, 1))
Case 1980 To 2019
Case Else:
arrE(I) = "Datum kleiner 1980 oder größer 2020"
End Select
Else
arrE(I) = "kein Datum"
End If
Next
.Range("E2:E" & lz) = Application.Transpose(arrE)
End With
End Sub

Und wenn die Formeln in Spalte E stehen bleiben können,
ist das noch schneller:

Sub DatumPrüf2()
With ActiveSheet
With .Cells(2, 5).Resize(.Cells(.Rows.Count, 4).End(xlUp).Row - 1)
.Formula = _
"=IF(ISBLANK(D2)+ISERROR(DAY(D2))>0,""kein Datum""," & _
"IF((YEAR(D2)<=1980)+(YEAR(D2)>2020)>0," & _
"""Datum kleiner 1980 oder größer 2020"",""""))"
'.Formula = .Value                               ' WENN NÖTIG
End With
End With
End Sub

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Hallo Ihr beiden!
Vielen DANK, klappt alles vorzüglich!
Schönen Tag noch
Petra