VBA-Code

Question

Hallo zusammen,
ich habe vor einiger Zeit einen Code von M.O, bekommen, wo beim öffnen der Datei nach dem aktuellen bzw. nächsten Geburtstag gesucht und markiert wird.

Option Explicit

Public Sub Workbook_Open()
Dim rngC As Range
ThisWorkbook.Worksheets(Format(Year(Date), "@")).Select
For Each rngC In Range("G5:G" & Cells(Rows.Count, 1).End(xlUp).Row)
If rngC = Date Then rngC.Select
Next
End Sub

Der einzige Unterschied ist, dass in der jetztigen Datei Die Gaburtsdaten nicht in Spalte A sondern in Spalte G stehen.
Das habe ich abgeänert (siehe Code).
Jetzt funktioniert es aber nicht mehr.
Er bleibt hier - ThisWorkbook.Worksheets(Format(Year(Date), "@")).Select - hängen.
Kann mir jemand sagen, wo der Fehler liegt?
Ich habe die Datei mal zum reinschauen hochgeladen.
Link: http://www.xup.in/dl,85115189/Schiedsrichterverzeichnis_2.xlsm/ .
Vielleicht habe ich den Code ja auch an die falsche Stelle rein kopiert.
Danke und Gruß Flodnug

Answer 1

Hallo,

ändere die Zeile

For Each rngC In Range("G5:G" & Cells(Rows.Count,
1).End(xlUp).Row)

in

For Each rngC In Range("G5:G" & Cells(Rows.Count,
7).End(xlUp).Row)

Gruß
Rainer

Answer 2

Hallo Rainer,
danke erstmal für Deine Antwort.
leider bleibt der Code immer noch an der serlben Stelle hängen.
Vielleicht könntest Du mal den Code in meiner Datei ausprobieren.
Danke nochmal für Deine Hilfe und Gruß Flodnug

Answer 3

Hallo,

ich habe deine Datei nicht runter geladen, sondern nur den Fehler
aufgezeigt, der mir beim Betrachten deines Postings auffiel.

Das Testen deines Codes überlasse ich dem Ersteller desselben.

Gruß
Rainer

Answer 4

Hallo Rainer,
ok, dann hoffe ich mal, dass M.O. demnächst mal drauf schaut.
Dir möchte ich aber nochmal für Dein Bemühen danken.
Gruß Flodnug

Answer 5

Hallo Flodnug,

der Code ist zwar nicht von mir, aber ich habe ihn mir mal trotzdem angeschaut ;-).
Du hast kein Blatt mit dem Namen 2016 in deiner Tabelle, daher kommt der Fehler, wenn du die Tabelle öffnest.
Hier mal ein Beispiel wie man den Fehler abfangen kann:

Public Sub Workbook_Open()
Dim rngC As Range
Dim ws As Worksheet

For Each ws In Worksheets
If ws.Name = Format(Year(Date), "@") Then
ws.Select
For Each rngC In Range("G5:G" & Cells(Rows.Count, 7).End(xlUp).Row)
If rngC = Date Then rngC.Select
Next rngC
End If
Next ws
End Sub

Gruß

M.O.

Answer 6

Hallo M.O.,
ich muss mich bei allen entschuldigen.
Ich habe aus einer falschen Datei den falschen Code gepostet. Beim alten Code sollte Excel zum aktuellen Datum springen und nicht wie gewünscht zum aktuellen oder nächsten Geburtstag.
Habe darum die Datei nochmal neu hochgeladen.
http://www.xup.in/dl,18256138/Schiedsrichterverzeichnis_2.xlsm/
Der nachfolgende Code ist jetzt aber von Dir M.O.

Private Sub Workbook_Open()
Dim GebArr As Variant
Dim lzeile As Long
Dim zaehler As Long
Dim gebDiv As Long
Dim strGef As String

'Tabelle mit der Geburtstagsliste aktivieren
ThisWorkbook.Worksheets("Tabelle1").Activate

'letzte Zeile in Spalte ermitteln
lzeile = ActiveSheet.Cells(Rows.Count, 6).End(xlUp).Row

'Array Re-Dimensioneren
ReDim GebArr(lzeile)

'Unterschied zwischen aktuellem Datum und Geburtstagsdatum im laufenden Jahr berechnen und in Array schreiben
For i = 5 To lzeile
GebArr(zaehler) = DateDiff("d", Date, DateSerial(Year(Date), Month(ActiveSheet.Cells(i, 6)), Day(ActiveSheet.Cells(i, 6))))
zaehler = zaehler + 1
Next i

'Variable für geringste Differnz zum aktuellem Datum vorbelegen
gebDiv = 999

'Nun Array durchlaufen und geringste Differnz suchen
For i = 0 To zaehler - 1
If GebArr(i) = 0 Or GebArr(i) > 0 Then 'nur wenn Differenz größer oder gleich Null ist
If gebDiv > GebArr(i) Then 'prüfen, welches kleinste Differnz ist
gebDiv = GebArr(i) 'Variable für Tagesdiffernz
End If
End If
Next i

'nun Array noch einmal durchlaufen und alle Zeilen, die der kleinsten Tagesdifferenz entsprechen in String für Markierung schreiben
For i = 0 To UBound(GebArr)
If GebArr(i) = gebDiv Then strGef = strGef & "B" & i + 5 & " ,"
Next i

'letztes Komma entfernen
strGef = Left(strGef, Len(strGef) - 1)

'gefundene Zeilen markieren
ActiveSheet.Range(strGef).Select
End Sub

Kannst Du bitte nochmal nachschauen.
Er bleibt jetzt nämlich an folgender Stelle hängen:
'letztes Komma entfernen
strGef = Left(strGef, Len(strGef) - 1)

Danke und Gruß Flodnug

Answer 7

Hallo Flodnug,

ja der Code kommt mir bekannt vor ;-).

Hier der angepasste Code:

Private Sub Workbook_Open()
Dim GebArr As Variant
Dim lzeile As Long
Dim zaehler As Long
Dim gebDiv As Long
Dim strGef As String

'Tabelle mit der Geburtstagsliste aktivieren
ThisWorkbook.Worksheets("Tabelle1").Activate

'letzte Zeile in Spalte ermitteln
lzeile = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row

'Array Re-Dimensioneren
ReDim GebArr(lzeile)

'Unterschied zwischen aktuellem Datum und Geburtstagsdatum im laufenden Jahr berechnen und in Array schreiben
For i = 5 To lzeile
GebArr(zaehler) = DateDiff("d", Date, DateSerial(Year(Date), Month(ActiveSheet.Cells(i, 7)), Day(ActiveSheet.Cells(i, 7))))
zaehler = zaehler + 1
Next i

'Variable für geringste Differnz zum aktuellem Datum vorbelegen
gebDiv = 999

'Nun Array durchlaufen und geringste Differnz suchen
For i = 0 To zaehler - 1
If GebArr(i) = 0 Or GebArr(i) > 0 Then 'nur wenn Differenz größer oder gleich Null ist
If gebDiv > GebArr(i) Then 'prüfen, welches kleinste Differnz ist
gebDiv = GebArr(i) 'Variable für Tagesdiffernz
End If
End If
Next i

'nun Array noch einmal durchlaufen und alle Zeilen, die der kleinsten Tagesdifferenz entsprechen in String für Markierung schreiben
For i = 0 To UBound(GebArr)
If GebArr(i) = gebDiv Then strGef = strGef & "B" & i + 5 & " ,"
Next i

'letztes Komma entfernen
strGef = Left(strGef, Len(strGef) - 1)

'gefundene Zeilen markieren
ActiveSheet.Range(strGef).Select
End Sub

Gruß

M.O.

Answer 8

Hallo M.O.,
danke erstmal für Deine Antwort.
Leider komme ich erst heute wieder zum antworten.
Ich habe Deinen Code eingefügt und leider festgestellt, dass es nicht funktioniert.
Excel meckert jetzt an folgender Stelle: GebArr(zaehler) = DateDiff("d", Date, DateSerial(Year(Date), Month(ActiveSheet.Cells(i, 7)), Day(ActiveSheet.Cells(i, 7))))
Könntest Du den Code mal in meiner hochgeladenen Datei ausprobieren?
Ich habe einiges ausprobiert undkomme einfach nicht mehr weiter.
Danke für Dein Bemühen und Gruß Flodnug

Answer 9

Hallo,

die Fehlermeldung kommt, wenn statt eines Datums z.B. "XXX" in der Zelle steht.
Ich habe den Code entsprechend erweitert, so dass der Fehler abgefangen wird:

Private Sub Workbook_Open()
Dim GebArr As Variant
Dim lzeile As Long
Dim zaehler As Long
Dim gebDiv As Long
Dim strGef As String

'Tabelle mit der Geburtstagsliste aktivieren
ThisWorkbook.Worksheets("Tabelle1").Activate

'letzte Zeile in Spalte G ermitteln
lzeile = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row

'Array Re-Dimensioneren
ReDim GebArr(lzeile - 5)

'Unterschied zwischen aktuellem Datum und Geburtstagsdatum im laufenden Jahr berechnen und in Array schreiben
For i = 5 To lzeile
If IsDate(Cells(i, 7)) = True Then 'Prüfen, ob Datum in Zelle vorliegt,
'falls ja, dann Unterschied in Array schreiben
GebArr(zaehler) = DateDiff("d", Date, DateSerial(Year(Date), Month(ActiveSheet.Cells(i, 7)), Day(ActiveSheet.Cells(i, 7))))
Else
GebArr(zaehler) = -9999 'falls nein, dann diesen Wert in Array schreiben
End If
'Zähler erhöhen
zaehler = zaehler + 1
Next i

'Variable für geringste Differnz zum aktuellem Datum vorbelegen
gebDiv = 999

'Nun Array durchlaufen und geringste Differnz suchen
For i = 0 To zaehler - 1
If GebArr(i) >= 0 Then 'nur wenn Differenz größer oder gleich Null ist
If gebDiv > GebArr(i) Then gebDiv = GebArr(i) 'prüfen, welches kleinste Differnz ist
End If
Next i

'nun Array noch einmal durchlaufen und alle Zeilen, die der kleinsten Tagesdifferenz entsprechen in String für Markierung schreiben
For i = 0 To zaehler - 1
If GebArr(i) = gebDiv Then strGef = strGef & "G" & i + 5 & " ,"
Next i

'letztes Komma entfernen
strGef = Left(strGef, Len(strGef) - 1)

'gefundene Zeilen markieren
ActiveSheet.Range(strGef).Select

End Sub

Gruß

M.O.

Answer 10

Hallo M.O.,
super, jetzt ist es genauso wie ich es wollte. Vielen Dank!
So kann es bleiben.
Trotzdem hätte ich noch eine Frage. Ist es ein größerer Aufwand den Code so zu erweitern, dass beim erneuten anklicken
(habe ein Button eingebaut), Excel zum wiederum nächsten Geburtstag (und das immer wieder) springt?
Wenn ja reicht mir ein kurzes Ja von Dir. Bei Nein wäre ich Dir, um die Erweiterungszeilen dankbar.
Danke nochmals und Gruß Flodnug