Aktuelles Datum finden - Ausgabe mehrerer Zellen...

Frage: In Spalte A in Tabelle 1 steht das Datum im Format z. B. "10.12.2012". In den Spalten B - D stehen dazugehörige Informationen. Nun soll das heutige Datum gesucht werden und die zugehörigen Informationen in einer MsgBox ausgegeben werden. Wie geht das?

Da es ja nicht unerhebliche Unterschiede in den Office / VBA Versionen gibt hier der Hinweis - erstellt und getestet in Excel 2010 / VBA7. Hier funktioniert das Suchen nach einem Datum (auch wenn es über eine Formel generiert wurde) wie unten gezeigt. In "älteren" Versioen muss gegebenenfalls angepasst werden (siehe Code).

Hier noch eine Beispieldatei: Aktuelles Datum finden - Ausgabe mehrerer Zellen...

Option Explicit
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 23.11.2012 
' Purpose   : Termin "Heute" finden Zellen daneben ausgeben Einzeln... 
'-------------------------------------------------------------------------- 
Sub Main()
    Dim strFirstAddress As String
    Dim rngRange As Range
    Dim rngCell As Range
    Dim strTMP As String
    On Error GoTo Fin
    With Tabelle1
        Set rngRange = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        Set rngCell = rngRange.Find(Date, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rngCell Is Nothing Then
            strFirstAddress = rngCell.Address
            Do
                strTMP = strTMP & "Folgenden Termine wurden gefunden: " & _
                    rngCell.Address(False, False) & _
                    " " & rngCell.Offset(0, 1).Text & _
                    " - " & rngCell.Offset(0, 2).Text & _
                    " " & rngCell.Offset(0, 3).Text & vbCrLf
                Set rngCell = rngRange.FindNext(rngCell)
            Loop While rngCell.Address <> strFirstAddress
            MsgBox strTMP
        Else
            MsgBox "Es wurden keine Termine gefunden!"
        End If
    End With
Fin:
    Set rngCell = Nothing
    Set rngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 23.11.2012 
' Purpose   : Termin "Heute" finden Zellen daneben ausgeben Alle... 
'-------------------------------------------------------------------------- 
Sub Main_1()
    Dim strFirstAddress As String
    Dim rngRange As Range
    Dim rngCell As Range
    On Error GoTo Fin
    With Tabelle1
        Set rngRange = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        Set rngCell = rngRange.Find(Date, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rngCell Is Nothing Then
            strFirstAddress = rngCell.Address
            Do
                MsgBox "Folgenden Termine wurden gefunden: " & _
                    rngCell.Address(False, False) & _
                    " " & rngCell.Offset(0, 1).Text & _
                    " - " & rngCell.Offset(0, 2).Text & _
                    " " & rngCell.Offset(0, 3).Text & vbCrLf
                Set rngCell = rngRange.FindNext(rngCell)
            Loop While rngCell.Address <> strFirstAddress
        Else
            MsgBox "Es wurden keine Termine gefunden!"
        End If
    End With
Fin:
    Set rngCell = Nothing
    Set rngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main_2 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 23.11.2012 
' Purpose   : Termin "Heute" finden Zellen daneben ausgeben Einzeln... 
'-------------------------------------------------------------------------- 
' Anpassung für ältere Office/VBA- Versionen 
Sub Main_2()
    Dim strFirstAddress As String
    Dim rngRange As Range
    Dim rngCell As Range
    Dim strTMP As String
    Dim dtmDate As Date
    On Error GoTo Fin
    dtmDate = Format(Date, "DD.MM.YYYY")
    With Tabelle1
        Set rngRange = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        Set rngCell = rngRange.Find(dtmDate, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rngCell Is Nothing Then
            strFirstAddress = rngCell.Address
            Do
                strTMP = strTMP & "Folgenden Termine wurden gefunden: " & _
                    rngCell.Address(False, False) & _
                    " " & rngCell.Offset(0, 1).Text & _
                    " - " & rngCell.Offset(0, 2).Text & _
                    " " & rngCell.Offset(0, 3).Text & vbCrLf
                Set rngCell = rngRange.FindNext(rngCell)
            Loop While rngCell.Address <> strFirstAddress
            MsgBox strTMP
        Else
            MsgBox "Es wurden keine Termine gefunden!"
        End If
    End With
Fin:
    Set rngCell = Nothing
    Set rngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...