Afrunding af dato til nærmeste dato i liste

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B2")) Is Nothing Then
        Dim I As Long, Dato As Variant
        Dato = [DATOLISTE]
        For I = UBound(Dato) To 1 Step -1
            If Target > Dato(I, 1) Then
            Application.EnableEvents = False
                Target = Dato(I, 1)
              Application.EnableEvents = True
                Exit Sub
            End If
        Next
    End If
End Sub


Navngiv din liste med datoer som DATOLISTE

sæt koden ind i arkmodulet på det ark som den skal virke på.

et alternativ: put i arkets kodemodul

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:B100")) Is Nothing Then Exit Sub
Dim r
  For r = 2 To Range("A65536").End(xlUp).Row
  If Target < Cells(r, 1) Then Target = Cells(r - 1, 1): Exit Sub
  Next
Target = Range("A65536").End(xlUp).Value
End Sub

Jeg har prøvet den første og den virker. Men hvad nu hvis jeg ikke vil have den skal afrunde datoen i b2, men skrive den afrundede dato i en anden celle ?

En anden ting er at hvis jeg skriver f.eks. 1/8-04 så nedrundes der til 1/4-04. Der skal den blive på 1/8-04

ret B2:B100 i linie 2 til det område du vil indtaster datoer i

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("B2:B100")) Is Nothing Then Exit Sub
Dim r
If Target < Range("A2") Then Target = Range("A2"): Exit Sub
  For r = 2 To Range("A65536").End(xlUp).Row
  If Target < Cells(r, 1) Then Target = Cells(r - 1, 1): Exit Sub
  Next
If Target > Range("A65536").End(xlUp).Value Then Target = Range("A65536").End(xlUp).Value
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B2:B100")) Is Nothing Then
        Dim I As Long, Dato As Variant
        Dato = [DATOLISTE]
        For I = UBound(Dato) To 1 Step -1
            If Target >= Dato(I, 1) Then
            Application.EnableEvents = False
                Target = Dato(I, 1)
              Application.EnableEvents = True
                Exit Sub
            End If
        Next
    End If
End Sub

dane022 > hvordan går det med denne sag