Tagesdifferenzen auswerten bzw. kennzeichnen

[Elke Boese]

Hallo,

(alles hier ist beispielhaft, es zählt hier nur das Prinzip)

mit folgendem kleinen Programm konstruiere ich erstmal meine Werte, die ich danach auswerten möchte.

Code:

Sub Werte_konstruieren()
Dim i%, vbVor, vbNach, vbV, vbN
vbVor = Array("Lili", "Elke", "Pit", "Gert", "Fred", "Tea")
vbNach = Array("Beck", "Lot", "Pop", "Tar", "Reck", "Stur")
'Namen nach Zufallsprinzip schreiben
For i = 1 To 100
vbV = vbVor(WorksheetFunction.RandBetween(0, 5))
vbN = vbNach(WorksheetFunction.RandBetween(0, 5))
Range("A" & i) = vbV & " " & vbN
Next
'Datum nach Zufallsprinzip schreiben
For Each Zelle In Range("a1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
Zelle.Offset(0, 1) = WorksheetFunction.RandBetween(9, 13) & ".06.2017"
Next
End Sub

Ausgehend von dem jeweils aktuellen Datum möchte ich nun  alle Werte kennzeichnen, die 2 oder 3 Tage zurückliegen.
Das mache ich hiermit:

Code:

Sub Tagesdifferenzen_Auswerten()
Columns(3).Clear: Columns(4).Clear
For Each Zelle In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
If CDate(Date) - CDate(Zelle.Offset(0, 1)) = 3 Then Zelle.Offset(0, 2) = "3 Tage"
If DateDiff("d", Zelle.Offset(0, 1), CDate(Date)) = 2 Then Zelle.Offset(0, 3) = "2 Tage"
Next
End Sub

So weit so gut. Welche Alternativen zur For Each Schleife (ist mir bei großen Datenmengen zu langsam) für eine solche Auswertung gibt es?
Danke schon mal für eure Mühe und Rat im voraus.

[Fennek]

Hallo Elke,

das sollte schneller sein:

Code:

Sub Fen()
f = Cells(1).CurrentRegion.Resize(, 4)
For i = 1 To UBound(f)
   If CDate(Date) - CDate(f(i, 2)) = 3 Then f(i, 3) = "3 Tage"
   If DateDiff("d", f(i, 2), CDate(Date)) = 2 Then f(i, 4) = "2 Tage"
Next i
Cells(1, 6).Resize(UBound(f), UBound(f, 2)) = f
End Sub

Testen: zuerst die Daten in Spalte A:B einfügen, dann meinen Code (schreibt ab Spalte 6), dann deinen Code zur Kontrolle

mfg

[Ego]

Hallo Elke,

auch das konstruieren kannst du mit der Nutzung eines Arrays stark beschleunigen.

Code:

Option Explicit
Sub Werte_konstruieren()
Dim i%, vbVor, vbNach, vbV, vbN, vbArr()
vbVor = Array("Lili", "Elke", "Pit", "Gert", "Fred", "Tea")
vbNach = Array("Beck", "Lot", "Pop", "Tar", "Reck", "Stur")
Const intAnz As Integer = 1000
'Namen nach Zufallsprinzip schreiben
ReDim vbArr(1 To intAnz, 1 To 2)
For i = 1 To intAnz
    vbV = vbVor(WorksheetFunction.RandBetween(0, 5))
    vbN = vbNach(WorksheetFunction.RandBetween(0, 5))
    vbArr(i, 1) = vbV & " " & vbN
    vbArr(i, 2) = CDate(WorksheetFunction.RandBetween(9, 13) & ".06.2017")
Next
Range("A1").Resize(intAnz, 2).Value = vbArr
End Sub

Sub Tagesdifferenzen_Auswerten()
Dim vbArr()
Dim intI As Integer
Dim datAkt As Date
datAkt = Date
Columns(3).Clear: Columns(4).Clear
vbArr = Range("A1").Resize(Cells(Rows.Count, 1).End(xlUp).Row, 4)
For intI = 1 To UBound(vbArr, 1)
    If datAkt - vbArr(intI, 2) = 3 Then vbArr(intI, 3) = "3 Tage"
    If datAkt - vbArr(intI, 2) = 2 Then vbArr(intI, 4) = "2 Tage"
Next intI
Range("A1").Resize(Cells(Rows.Count, 1).End(xlUp).Row, 4) = vbArr
End Sub

ps. Gibt es einen Grund, warum du das Datum beim Konstruieren als Text abgespeichert hast?

[Elke Boese]

Hallo,

bitte helft mir weiter. Statt wie Fennek und Ego ein Feld zu verwenden, habe ich mir überlegt, dass es auch mit dem  Autofilter gehen müßte.

Code:

Sub Datum_Filtern2()

With Sheets("Tabelle1")

'Autofilter einschalten
.Columns(2).AutoFilter Field:=1, Criteria1:=CStr(DateAdd("d", -3, Date))

'mit dem Filter gefundene Werte auswählen
.AutoFilter.Range.Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Select

'Ergebnisse der Auswahl kennzeichnen und in Spalte C schreiben
For Each Zelle In Selection
Zelle.Offset(0, 1) = "3 Tage"
Next

'Autofilter wieder ausschalten
.Columns(2).AutoFilter
End With

End Sub

Wie ihr anhand meines Codes sehen könnt, habe ich alle mit dem Autofilter gefundenen Werte erstmal selektiert und die selektierten Werte

dann über eine For Each - Schleife, als Ergebnis in Spalte C geschrieben.

Jetzt frage ich mich aber, welche Alternativen es gibt, die durch den Autofilter gefundenen Werte auszulesen, anstatt eine For Each - Schleife

zu verwenden?

[Kuwer]

Hallo Elke,

Sub Tagesdifferenzen_Auswerten()

 Columns("C:D") = ""

 With Range("B1").Resize(Cells(Rows.Count, 2).End(xlUp).Row)

   .Offset(, 1).Formula = "=IF(TODAY()-B1=3,""3 Tage"","""")"

   '.Offset(, 1).Value = .Offset(, 1).Value

   .Offset(, 2).Formula = "=IF(TODAY()-B1=2,""2 Tage"","""")"

   '.Offset(, 2).Value = .Offset(, 2).Value

 End With

End Sub

Gruß Uwe