ciao

al posto di

.Select

metti

Range("B7").End(xlDown).Offset(1, 0).Select

Ciao,

potresti risolvere aggiungedo un controllo nell'evento SelectionChange in modo che se selezioni una cella del range C7:O20 e la relativa riga è sotto all'ultima riga che contiene una data in colonna B allora si posiziona sulla cella B.

Questo il codice da inserire nel modulo ThisWorkbook (elimina gli altri codici dai moduli dei singoli fogli).

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Dim rng As Range, rLR As Range
  
  If Sh.CodeName <> "Foglio1" Then 'esclude dal controllo il Foglio1
    Set rng = Sh.Range("B7:B20")
    Set rLR = rng.Find(what:="*", _
                     After:=rng.Cells(1), _
                     LookAt:=xlPart, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByRows, _
                     SearchDirection:=xlPrevious, _
                     MatchCase:=False)
  
    If rLR Is Nothing Then Set rLR = Sh.Range("B6")
    If Not rLR Is Nothing And Not Intersect(Target, Sh.Range("C7:O20")) Is Nothing Then
      If rLR.Row < Target.Row Then
        Application.EnableEvents = False
        rLR.Offset(1).Select
        Application.EnableEvents = True
        MsgBox "Manca la data o formato data errato" & vbCrLf & _
        "nella cella < " & ActiveCell.Address & " > !", vbCritical + vbOKOnly + vbDefaultButton2, "ERRORE!"
      End If
    End If
  End If
End Sub

Allegato il file

Sostituisci tutta la routine con questa:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Dim rng As Range, rLR As Range, bDate As Boolean, bDtValid As Boolean
  
  If Sh.CodeName <> "Foglio1" Then 'esclude dal controllo il Foglio1
    Set rng = Sh.Range("B7:B20")
    Set rLR = rng.Find(what:="*", _
                     After:=rng.Cells(1), _
                     LookAt:=xlPart, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByRows, _
                     SearchDirection:=xlPrevious, _
                     MatchCase:=False)
  
    If rLR Is Nothing Then Set rLR = Sh.Range("B6")
    If Not rLR Is Nothing And Not Intersect(Target, Sh.Range("B7:O20")) Is Nothing Then
      If rLR.Row < Target.Row Then
        Application.EnableEvents = False
        rLR.Offset(1).Select
        Application.EnableEvents = True
        MsgBox "Manca la data " & vbCrLf & _
        "nella cella < " & ActiveCell.Address & " > !", vbCritical + vbOKOnly + vbDefaultButton2, "ERRORE!"
      Else
        If Not Intersect(Target, Sh.Range("B7:B20")) Is Nothing Then
          bDate = IsDate(ActiveCell.Value)
          If bDate Then bDtValid = CDate(ActiveCell.Value) >= CDate("01/01/2000")
          If Not bDate Or Not bDtValid Then
            Application.EnableEvents = False
              ActiveCell.ClearContents
            Application.EnableEvents = True
            MsgBox "data non valida " & vbCrLf & _
            "nella cella < " & ActiveCell.Address & " > !", vbCritical + vbOKOnly + vbDefaultButton2, "ERRORE!"
          End If
        End If
      End If
    End If
  End If
End Sub

N.B.: ricordati di cancellare dai moduli dei singoli fogli tutti i codici di evento (nel file che avevo allegato avevo lasciato quello nel Folio3).

Riallego il file corretto.

frank_ciccio ha scritto:

Scrivo un valore diverso da una data esempio kkkkk in B12 nessun avviso

Nel file che ho allegato a me funziona: se scrivo adasd in B12 mi da l'avviso e cancella il contenuto.

Sicuro di aver cancellato gli eventi dai singoli fogli?

Non so cosa dirti:

prova a dire tutti i passaggi che fai, dall'apertura del file, per replicare il problema.

frank_ciccio ha scritto:

Scrivo in B12 dddd > invio nella cella resta dddd

A me, come hai visto dalla gif sopra non succede, comunque ho rivisto un po' il codice, sostituiscilo a quello che hai:

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  Dim rng As Range, rLR As Range, bDate As Boolean, bDtValid As Boolean

  If Sh.CodeName <> "Foglio1" Then 'esclude dal controllo il Foglio1
    Set rng = Sh.Range("B7:B20")
    Set rLR = rng.Find(what:="*", _
                     After:=rng.Cells(1), _
                     LookAt:=xlPart, _
                     LookIn:=xlFormulas, _
                     SearchOrder:=xlByRows, _
                     SearchDirection:=xlPrevious, _
                     MatchCase:=False)
  
    If rLR Is Nothing Then Set rLR = Sh.Range("B6")
    If Not rLR Is Nothing And Not Intersect(Target, Sh.Range("B7:O20")) Is Nothing Then
      If rLR.Row + IIf(ActiveCell.Column = 2, 1, 0) < Target.Row Then
        Application.EnableEvents = False
        rLR.Offset(1).Select
        Application.EnableEvents = True
        MsgBox "Manca la data " & vbCrLf & _
        "nella cella < " & ActiveCell.Address & " > !", vbCritical + vbOKOnly + vbDefaultButton2, "ERRORE!"
      Else
        If Not Intersect(Target, Sh.Range("B7:B20")) Is Nothing Then
            bDate = IsDate(ActiveCell.Value)
            If bDate Then bDtValid = CDate(ActiveCell.Value) >= CDate("01/01/2000")
            If Not bDate Or Not bDtValid Then
              If ActiveCell <> "" Then MsgBox "data non valida " & vbCrLf & _
              "nella cella < " & ActiveCell.Address & " > !", vbCritical + vbOKOnly + vbDefaultButton2, "ERRORE!"
              Application.EnableEvents = False
                ActiveCell.ClearContents
              Application.EnableEvents = True
            End If
         
        End If
      End If
    End If
  End If
End Sub

scossa ha scritto:

A me, come hai visto dalla gif sopra non succede

Vero ma accade perche' ti sposti con un colpo di mouse in una cella che gia' contiene un valore valido.

Frank_ciccio osserva invece che se scrivo una data non valida, per esempio una stringa di testo, in una cella e premo invio, la selezione attiva si sposta e viene intercettato questo cambiamento, ma non il fatto che ho inserito un valore non valido nella cella. Per questo caso secondo me serve implementare il codice per il relativo evento SheetChange (dal momento che siamo in ThisWorkbook).

Proposta di integrazione:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim bDate As Boolean
Dim bDtValid As Boolean

    Application.EnableEvents = False
        If Not Intersect(Target, Sh.Range("B7:B20")) Is Nothing Then
           bDate = IsDate(Target.Value)
           If bDate Then bDtValid = CDate(Target.Value) >= CDate("01/01/2000")
           If Not bDate Or Not bDtValid Then
            Target.Select
                If Trim(Target) <> "" Then MsgBox "data non valida " & vbCrLf & _
                    "nella cella < " & Target.Address & " > !", vbCritical + vbOKOnly + vbDefaultButton2, "ERRORE!"
               ActiveCell.ClearContents
            End If
        End If
    Application.EnableEvents = True
End Sub

Con l'inconveniente che se inserisco una data non valida prima mi viene segnalato l'errore, poi il dato viene cancellato dalla macro di selezione, poi parte l'avviso che manca la data. Insomma una sequenza di beep fastidiosi 🙂

Non mi è molto chiaro il controllo sulla data "01/01/2000"...forse si sta verificando se la data inserita non sia inferiore al "01/01/2000"?

Se fosse così, io proporrei questo (da inserire in "ThisWorkbook" o "Questa_cartella_di_lavoro"):

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Dim rng As Range, c As Range, ur As Range

If Sh.CodeName = "Foglio1" Then Exit Sub

Set rng = Sh.Range("B7:B20")

Set rng = Sh.Range("B7:B20")
Set ur = rng.Find(What:="*", _
            After:=rng.Cells(1), _
            LookAt:=xlPart, _
            LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlPrevious, _
            MatchCase:=False)

If ur Is Nothing Then Set ur = Sh.Range("B7")

For Each c In Sh.Range("B7:" & ur.Address)
    If IsDate(c.Value) Then
        If CDate(c.Value) < DateSerial(2000, 1, 1) Then
            MsgBox "Attenzione...la data non può essere inferiore al ""01/01/2000""", vbCritical, "Attenzione..."
            Application.EnableEvents = False
            c.ClearContents
            c.Select
            Application.EnableEvents = True
            Exit Sub
        End If
    ElseIf Not IsEmpty(c.Value) Then
        MsgBox "Attenzione...il valore inserito non è una data.", vbCritical, "Attenzione..."
        Application.EnableEvents = False
        c.ClearContents
        c.Select
        Application.EnableEvents = True
        Exit Sub
    End If
Next c

If Not Intersect(Target, Sh.Range("B" & ur.Row + 1 & ":O20")) Is Nothing Then
    If Not IsEmpty(Sh.Range("B7")) Then
        If Intersect(Target, Sh.Range("B" & ur.Row + 1)) Is Nothing Then
            MsgBox "Attenzione...per ora puoi selezionare solo la cella < " & ur.Row + 1 & " >", vbCritical, "Attenzione..."
            Application.EnableEvents = False
            Sh.Cells(ur.Row + 1, "B").Select
            Application.EnableEvents = True
        End If
    Else
        MsgBox "Attenzione...per ora puoi selezionare solo la cella < " & ur.Row & " >", vbCritical, "Attenzione..."
        Application.EnableEvents = False
        Sh.Cells(ur.Row, "B").Select
        Application.EnableEvents = True
    End If
End If

Set rng = Nothing
Set ur = Nothing

End Sub

scossa ha scritto:

invece no: l'evento SelectionChange (a dispetto di come è scritto il nome) viene scatenato sia in caso di Selection sia di Change; la cosa è immediatamente verificabile se disattivate lo spostamento del cursore dopo Invio

Si' ma e' un effetto collaterale perche' la conferma di un dato con Invio produce comunque lo spostamento della cella --si rimane sulla stessa cella perche' abbiamo disattivato lo spostamento, e' vero, ma internamente i due eventi sono distinti. Anche se producono all'atto pratico il medesimo effetto (in questo caso).