MON CODE NE FONCTIONNE PAS

[chich]

Bonjour a la communauté
j’essaye de me débrouillé avec l'enregistreur de macro mais la je but un cou de main serais le bien venu
merci d’avance
Private Sub ToggleButton3_Click()
Application.ScreenUpdating = False
Selection.Validation
ActiveCell.EntireRow.Delete
Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertWarning, Operator _
:=xlBetween, Formula1:="=MOD(M11>Q11;1)>=0,5"
ActiveCell.FormulaR1C1 = " : "
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=RC[-1]>TIME(12,00,0)"
ActiveCell.Offset(0, -4).Select
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = "Amplitude"
.InputMessage = ""
.ErrorMessage = _
" ATTENTION " & Chr(10) & "Veuillez respecter les amplitudes horaires" & Chr(10) & ""
.ShowInput = True
.ShowError = True
ActiveCell.FormulaR1C1 = "10:00"
ActiveCell.Offset(0, 1).Select
ActiveCell.FormulaR1C1 = "=RC[-1]+TIME(7,00,0)"
ActiveCell.Offset(0, 4).Select
Load UserForm2
End Sub

 

[job75]

Bonjour chich, Si..., le forum,

Puisque chich tient au VBA voyez ce contrôle des entrées dans le fichier joint :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim deb As Range, h, i&, j%
Set deb = [B11]: h = deb '1ère cellule
Application.EnableEvents = False
For i = 1 To 5 * 52 Step 5
  For j = 1 To 5 * 7 Step 5
    If Not IsEmpty(deb(i, j)) Then
      If Not IsDate(deb(i, j).Text) Then deb(i, j).Select: _
         MsgBox "Entrez une heure valide !", 48: deb(i, j) = "": GoTo 1
      If 1 + deb(i, j) < h + 19 / 24 Then deb(i, j).Select: _
        MsgBox "L'amplitude de 12 heures n'est pas respectée !", 48: deb(i, j) = "": GoTo 1
    End If
    h = deb(i, j)
Next j, i
1 Application.EnableEvents = True
End Sub

A+

 

[job75]

Re,

Fichier (2) avec un p'tit gadget :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Target.HasFormula And IsDate(Target.Text) Then _
  If Target < 1 Then Cancel = True: Target = Format(Target + 1 / 96, "hh:mm")
End Sub

A+

 

[chich]

Bonjour chich, Si..., le forum,

Puisque chich tient au VBA voyez ce contrôle des entrées dans le fichier joint :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim deb As Range, h, i&, j%
Set deb = [B11]: h = deb '1ère cellule
Application.EnableEvents = False
For i = 1 To 5 * 52 Step 5
  For j = 1 To 5 * 7 Step 5
    If Not IsEmpty(deb(i, j)) Then
      If Not IsDate(deb(i, j).Text) Then deb(i, j).Select: _
         MsgBox "Entrez une heure valide !", 48: deb(i, j) = "": GoTo 1
      If 1 + deb(i, j) < h + 19 / 24 Then deb(i, j).Select: _
        MsgBox "L'amplitude de 12 heures n'est pas respectée !", 48: deb(i, j) = "": GoTo 1
    End If
    h = deb(i, j)
Next j, i
1 Application.EnableEvents = True
End Sub

A+

Bonjour la cosmonaute
Super c'est exactement se je voulait faire merci pour votre perceverance a m’accompagniez dans mon projet
pour y maitre un point final j'ai une dernier demande comment je peux ce tableau qui represnte une semaine en selectionnant dans une liste deroulante des numeros de semaine je peux voir et travailler sur toutes les semaine de l'annee (semaine dynamique )

 

[job75]

Re,

J'ai modifié les MFC de mes 3 derniers fichiers, -"1E-6" y est quand même nécessaire.

Pour la dernière question c'est un autre problème, ouvrez une nouvelle discussion.

En joignant le fichier que vous aurez retenu.

A+

 

[chich]

RE
OK merci beaucoup votre gaget m'ai bien utile

 

[job75]

Re,

Finalement comme ce n'est pas grand-chose, dans la macro Worksheet_Change :

Set deb = Intersect(Target, [B6])
If Not deb Is Nothing Then
  Set deb = [AJ:AJ].Find(Mid(deb, 9), , xlValues, xlWhole)
  If Not deb Is Nothing Then
    If deb = "" Then deb = "Semaine 1"
    Application.ScreenUpdating = False
    Application.Goto deb, True 'cadrage
    ActiveWindow.ScrollColumn = 1
    Cells(ActiveCell.Row + 3, 2).Select
  End If
  Exit Sub
End If

Edit : ajouté If deb = "" Then deb = "Semaine 1"

Fichier (3).

A+

 

[chich]

Re,

Finalement comme ce n'est pas grand-chose, dans la macro Worksheet_Change :

Set deb = Intersect(Target, [B6])
If Not deb Is Nothing Then
  Set deb = [AJ:AJ].Find(Mid(deb, 9), , xlValues, xlWhole)
  If Not deb Is Nothing Then
    Application.ScreenUpdating = False
    Application.Goto deb, True 'cadrage
    ActiveWindow.ScrollColumn = 1
    Cells(ActiveCell.Row + 3, 2).Select
  End If
  Exit Sub
End If

Fichier (3).

A+

re
Geniale MERCI A+