Prüfung in Array?

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

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)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

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)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

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread