Public annul 'Evite les rebouclages multiples dans les Worksheet_Change
Dim X As Integer
Dim Y As Byte
Private Sub Réserve_Click()
Set f = New Réserve
f.Show
Set f = Nothing
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Clic en dehors du tableau pour effacer les lignes coloriées
Range("A20:H" & Range("H65535").End(xlUp).Row).Interior.Pattern = xlNone
'Pour la partie désignation
If Not Intersect(Target, Range("A20:B38")) Is Nothing And Target.Count = 1 Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Interior.Color = RGB(255, 192, 0)
End If
If Not Intersect(Target, Range("C20:E38")) Is Nothing And Target.Count = 4 Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Interior.Color = RGB(255, 192, 0)
If Len(Cells(Target.Row, 3)) > 75 Then
If Cells(Target.Row, 3).RowHeight = 15 Then testhauteur = 1
Cells(Target.Row, 3).RowHeight = 30
Else
If Cells(Target.Row, 3).RowHeight = 30 Then testhauteur = -1
Cells(Target.Row, 3).RowHeight = 15
End If
If testhauteur = 1 Then
For ligne = 38 To 20 Step -1
If Cells(ligne, 1).RowHeight > 0 And Cells(ligne, 1).Value = "" And compte = 0 Then
Cells(ligne, 1).RowHeight = 0
compte = 1
End If
Next ligne
If ligne = 0 Then MsgBox "La facture dépasse 1 page"
End If
If testhauteur = -1 Then
For ligne = 38 To 20 Step -1
If Cells(ligne, 1).RowHeight = 0 And compte = 0 Then
Cells(ligne, 1).RowHeight = 15
compte = 1
End If
Next ligne
End If
End If
If Not Intersect(Target, Range("F20:H38")) Is Nothing And Target.Count = 1 Then
Range(Cells(Target.Row, 1), Cells(Target.Row, 8)).Interior.Color = RGB(255, 192, 0)
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Or annul = 1 Then annul = 0: Exit Sub
'Mettre en majuscule des cellules
If Target.Address = "$A$5" Then annul = 1: Cells(5, 1) = StrConv(Cells(5, 1), 1): Exit Sub
If Target.Address = "$A$13" Then annul = 1: Cells(13, 1) = StrConv(Cells(13, 1), 1): Exit Sub
If Target.Address = "$A$15" Then annul = 1: Cells(15, 1) = StrConv(Cells(15, 1), 1): Exit Sub
If Target.Address = "$G$14" Then annul = 1: Cells(14, 7) = StrConv(Cells(14, 7), 1): Exit Sub
'Mettre en majuscule la première lettre
If Not Intersect(Target, Range("C20:E38")) Is Nothing Then annul = 1: Target = UCase(Left(Target, 1)) & Mid(Target, 2): Exit Sub
annul = 0
End Sub