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 Flodnug,

auch das wäre möglich. Kannst du mal deine aktuelle Datei mit dem Button hochladen, dann könnte ich mich mal übers Wochenende damit beschäftigten.

Gruß

M.O.

Answer 2

Hallo M.O.,
vielen Dank erstmal für Deine Bereitschaft, mir noch weiter zu helfen,
obwohl es ja nur noch um "Makulatur" geht.
Ich habe in der Datei mal ein paar Daten mehr drin gelassen.
So kannst Du mal (falls gewünscht) die eine oder andere Sortierfunktion sinnvollerweise benutzen.
An Deinem Code habe ich nur (damit ich den Button erstellen konnte) nur in der 1.Zeile aus
Private Sub Workbook_Open()
Public Sub Workbook_Open()
gemacht.
http://www.xup.in/dl,92902564/Schiedsrichterverzeichnis_-_Kopie.xlsm/
Danke und Gruß Flodnug

Answer 3

Hallo M.O.,
da ich nicht weiss, ob das wichtig ist, muss ich noch sagen,
dass ich im Code aus "Tabelle1" wieder (wir im Original) "SR-Verz."
gemacht habe, da ich das in der Datei genauso gemacht habe.
Gruß Flodnug

PS.: Wenn ich den Cursor irgendwo hin bewegt habe oder etwas geschrieben habe
oder eine Sortierfunktion benutzt etc. sollte möglichst die Suche nach dem aktuellen/nächsten
Geburtstag natürlich wieder von vorn beginnen.

Answer 4

Hallo Flodnug,

das aber ganz schön viele Wünsche ;-).

Ändere das Makro im VBA-Projekt der Arbeitsmappe wie folgt:

Private Sub Workbook_Open()
'Tabelle mit der Geburtstagsliste aktivieren
ThisWorkbook.Worksheets("SR-Verz.").Activate

'gespeicherte Position löschen
Range("G1").ClearContents

'falls beim Öffnen der Datei das Makro zum Markieren der Geburtstage aufgerufen werden soll, dann
Call Geburtstag_suchen

End Sub

Falls das Makro zum Suchen der Geburtstage nicht automatisch beim Öffnen der Mappe ausgeführt werden soll, dann lösche die Call-Anweisung.
Kopiere den folgenden Code in ein allgemeins Modul:

Sub Geburtstag_suchen()

Dim GebArr As Variant
Dim lzeile As Long
Dim zaehler As Long
Dim zaehler2 As Long
Dim gebDiv As Long
Dim GefArr As Variant
Dim lngPos As Long

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

'Arrays Re-Dimensioneren
ReDim GebArr(lzeile - 5)
ReDim GefArr(lzeile - 5)

'letzte gespeicherte Position auslesen
lngPos = Range("G1").Value

'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 neues Array schreiben
For i = 0 To zaehler - 1
If GebArr(i) = gebDiv Then
GefArr(zaehler2) = i + 5
zaehler2 = zaehler2 + 1
End If
Next i

'Prüfen, ob etwa in Zelle G1 gestanden hat, und ggf. Zähler erhöhen
If IsEmpty(Range("G1")) = False Then
'Prüfen, ob Cursor noch auf letzter markierter Zelle steht
If ActiveCell.Column <> 7 Or ActiveCell.Row <> GefArr(lngPos) Then
'falls ja, dann Marker für Position auf Null setzen
lngPos = 0
Else
'sonst Marker um 1 erhöhen
lngPos = lngPos + 1
End If
End If

'gefundene Zeilen markieren
If lngPos > zaehler2 - 1 Then
MsgBox "Keine weiteren Geburtstage gefunden!", 48, "Hinweis"
Else
ActiveSheet.Range("G" & GefArr(lngPos)).Select
End If

Range("G1") = lngPos

End Sub

Deiner Schaltfläche musst du natürlich dann das obige Makro zuweisen.
Ergänze deine verschiedenen Code zum Sortieren in diesem Arbeitsblatt am Ende um folgende Zeilen:

'gespeicherte Position für Geburtstagssuche löschen
Range("G1").ClearContents

Gruß

M.O.

Answer 5

Hallo M.O.,
konnte Deinen Code jetzt testen.
Es funzt prima.
Hab vielen Dank für Deine Hilfe trotz des dadurch verkürzten Wochenendes.
Ich verbleibe also nochmal mit einem Extradank und einem Gruß Flodnug.

Answer 6

Hallo Flodnug,

vielen Dank für die Rückmeldung. Es freut mich, dass das Makro so funktioniert, wie du willst. Und allzu verkürzt war das Wochenende dadurch nicht ;-).

Gruß

M.O.