AW: Runde Geb.
28.12.2008 19:02:00
Ramses
Hallo
Sub Find_GebRund()
'by Ramses
'Erstellt Tabelle mit runden Geburtstagen
'Variablen Deklaration
Dim lastRow As Long, srcCol As Long, i As Long, tarRow As Long
Dim Qe As Long
Dim srcWks As Worksheet, tarWks As Worksheet
Dim tarName As String, overWrite As Boolean
'Name für Zieltabelle definieren
tarName = "Geb. vom " & Format(Now, "dd.mm.yy") & " bis " & Format(Now, "dd.mm.yy")
'Name der Quelltabelle mit den Geburtsdaten anpassen !!
Set srcWks = Worksheets("Sheet1")
overWrite = False
'Prüfen ob die Tabelle schon existiert
For i = 1 To Worksheets.Count
If Worksheets(i).Name = tarName Then
Qe = MsgBox("Die Tabelle für heute wurde schon erstellt." & vbCrLf & "Soll sie überschrieben werden ?", vbQuestion + vbYesNo, "Frage")
If Qe = vbYes Then
Worksheets(tarName).Cells.Clear
overWrite = True
Else
'... Tabellenname mit Erweiterung "_X" erstellen
tarName = tarName & "_" & Worksheets.Count
End If
End If
Next i
'Wenn die Tabelle noch nicht existiert...
If overWrite = False Then
'... dann neu erstellen
Set tarWks = Worksheets.Add
With tarWks
.Name = tarName
.Move after:=Worksheets(Worksheets.Count)
End With
Else
'bzw. Variable auf Zieltabelle zuweisen
Set tarWks = Worksheets(tarName)
End If
'Spalte mit den Geburtsdaten
srcCol = 1
'Letzten Eintrag in dieser Spalte bestimmen
lastRow = srcWks.Cells(Rows.Count, srcCol).End(xlUp).Row
'Erste Zeile der neuen Tabelle definieren
tarRow = 1
With srcWks
'2 = Zeile wo die Daten beginnen
For i = 2 To lastRow
If IsDate(.Cells(i, srcCol)) Then
'alle 5 jährigen über 50
Debug.Print (Year(Now) - Year(.Cells(i, srcCol))) Mod 5
Debug.Print (Year(Now) - Year(.Cells(i, srcCol)))
Select Case (Year(Now) - Year(.Cells(i, srcCol))) Mod 5
Case 0 And Year(Now) - Year(.Cells(i, srcCol)) >= 50
.Rows(i).Copy tarWks.Cells(tarRow, 1)
tarRow = tarRow + 1
Case Else
If Year(Now) - Year(.Cells(i, srcCol)) > 90 Then
.Rows(i).Copy tarWks.Cells(tarRow, 1)
tarRow = tarRow + 1
End If
End Select
End If
Next i
End With
End Sub
Gruss Rainer