Rectifier les insertions de données dans un tableau

Le 27/08/2025 à 22:30

Bonjour,

Suite au code de BsAlv, j'ai rajouté des lignes manuellement car je ne sais pas le faire en VBA, pour avoir 200 lignes.

Cependant le code VBA était prévu pour inscrire les nouveaux sportifs à la fin du tableau.

Or avec mes changements, ça pose problème car au lieu que les nouveaux inscrits s'enregistrent à la suite des sportifs, ils s'ajoutent à la suite des 200 lignes, soit en ligne 201 et 202.

Pouvons nous réussir à corriger ce problème ?

image

Voici le code VBA à modifier dans la feuille "5 ateliers" :

'Feuille 5 ateliers

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
     Dim DerLig_f2 As Long
     Dim x     As Object
     Dim Nom As String, Prenom As String
     'enlever le mot de passe
     ActiveSheet.Unprotect Password:="seb"

     On Error GoTo Sortie
     Application.EnableEvents = False
     If Not Intersect(Target, Range("Z3:Z1000")) Is Nothing Then
          Nom = Target.Value
          Prenom = Target.Offset(0, 1).Value
          Sexe = Target.Offset(0, 2).Value
          DerLig_f2 = Range("A" & Rows.Count).End(xlUp).Row
          If DerLig_f2 < 3 Then
               DerLig_f2 = 2
               Cells(DerLig_f2 + 1, "A") = UCase(Nom)
               Cells(DerLig_f2 + 1, "B") = Application.Proper(Prenom)
               Cells(DerLig_f2 + 1, "C") = UCase(Sexe)
               If UCase(Sexe) = "F" Then
                    Range(Cells(DerLig_f2 + 1, "A"), Cells(DerLig_f2 + 1, "C")).Font.Color = RGB(255, 0, 255)
               Else
                    Range(Cells(DerLig_f2 + 1, "A"), Cells(DerLig_f2 + 1, "C")).Font.Color = RGB(0, 0, 0)
               End If

          Else
               Cells(DerLig_f2 + 1, "A") = UCase(Nom)
               Cells(DerLig_f2 + 1, "B") = Application.Proper(Prenom)
               Cells(DerLig_f2 + 1, "C") = UCase(Sexe)
               Cells(DerLig_f2 + 1, "A").Select

               If UCase(Sexe) = "F" Then
                    Range(Cells(DerLig_f2 + 1, "A"), Cells(DerLig_f2 + 1, "C")).Font.Color = RGB(255, 0, 255)
                    Cells(DerLig_f2 + 1, "X").Font.Color = RGB(255, 0, 255)
               Else
                    Range(Cells(DerLig_f2 + 1, "A"), Cells(DerLig_f2 + 1, "C")).Font.Color = RGB(0, 0, 0)
                    Cells(DerLig_f2 + 1, "X").Font.Color = RGB(0, 0, 0)
               End If

               Nb = Application.WorksheetFunction.CountIfs(Range("A1:A" & DerLig_f2 + 1), Nom, _
                                                           Range("B1:B" & DerLig_f2 + 1), Prenom, _
                                                           Range("C1:C" & DerLig_f2 + 1), Sexe)

               If Nb > 1 Then
                    'recherche de la présence de ce nom dans la colonne A
                    With Range("A2:A" & DerLig_f2 + 1)
                         Set x = .Find(UCase(Nom), lookat:=xlWhole)
                         If Not x Is Nothing Then
                              Deb = x.Row
                              Do
                                   If Cells(x.Row, "B") = Application.Proper(Prenom) And Cells(x.Row, "C") = Sexe Then
                                        'Cells(x.Row, "A").Select
                                        Range(Cells(x.Row, "A"), Cells(x.Row, "C")).Interior.Color = RGB(255, 255, 0)
                                        'ActiveWindow.ScrollRow = x.Row - 10
                                        'GoTo Sortie
                                        'Else
                                   End If
                                   Set x = .FindNext(x)
                              Loop While Not x Is Nothing And x.Row <> Deb
                         End If
                         If DerLig_f2 > 20 Then ActiveWindow.ScrollRow = DerLig_f2 - 10
                    End With
               End If
          End If
     End If
Sortie:
     Centrage_Des_Valeurs_5_ateliers
     Application.EnableEvents = True
     'Protéger la feuille
     'ActiveSheet.Protect Password:="seb", UserInterfaceOnly:=True
End Sub

Sub Tri_Alpha_Col_AX()
     With Me.ListObjects("TBL_5Ateliers").Range
          .Sort .Range("A1"), xlAscending, , .Range("B1"), xlAscending, Header:=xlYes
     End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
     On Error GoTo Sortie
     Set f2 = Sheets("5 ateliers")
     DerLig_f2 = f2.Range("Z" & f2.Rows.Count).End(xlUp).Row

     Application.EnableEvents = False
     If Target.Column = 1 And Target.Row > 2 Then
          Nom = Target.Value
          Cells(Target.Row, "A") = UCase(Nom)
          Nb = Application.WorksheetFunction.CountIf(Range("Z1:Z" & DerLig_f2 + 1), Nom)
          If Nb = 0 Then
               With Range(Cells(Target.Row, "A"), Cells(Target.Row, "C"))
                    .Font.Color = RGB(0, 0, 0)
                    .Interior.Color = RGB(0, 255, 0)
               End With
          Else
               With Range(Cells(Target.Row, "A"), Cells(Target.Row, "C"))
                    .Font.Color = RGB(0, 0, 0)
                    .Interior.ColorIndex = xlNone
               End With
          End If
     ElseIf Target.Column = 2 And Target.Row > 2 Then
          Nom = Target.Offset(0, -1).Value
          Prenom = Target.Value
          Cells(Target.Row, "A") = UCase(Nom)
          Cells(Target.Row, "B") = Application.Proper(Prenom)
          Nb = Application.WorksheetFunction.CountIfs(Range("Z1:Z" & DerLig_f2 + 1), Nom, Range("AA1:AA" & DerLig_f2 + 1), Prenom)
          If Nb = 0 Then
               With Range(Cells(Target.Row, "A"), Cells(Target.Row, "C"))
                    .Font.Color = RGB(0, 0, 0)
                    .Interior.Color = RGB(0, 255, 0)
               End With
          Else
               With Range(Cells(Target.Row, "A"), Cells(Target.Row, "C"))
                    .Font.Color = RGB(0, 0, 0)
                    .Interior.ColorIndex = xlNone
               End With
          End If
     ElseIf Target.Column = 3 And Target.Row > 2 Then
          Nom = Target.Offset(0, -2).Value
          Prenom = Target.Offset(0, -1).Value
          Sexe = Target.Value
          Cells(Target.Row, "A") = UCase(Nom)
          Cells(Target.Row, "B") = Application.Proper(Prenom)
          Cells(Target.Row, "C") = UCase(Sexe)
          Nb = Application.WorksheetFunction.CountIfs(Range("Z1:Z" & DerLig_f2 + 1), Nom, Range("AA1:AA" & DerLig_f2 + 1), Prenom, Range("AB1:AB" & DerLig_f2 + 1), Sexe)
          If Nb = 0 Then
               With Range(Cells(Target.Row, "A"), Cells(Target.Row, "C"))
                    .Font.Color = RGB(0, 0, 0)
                    .Interior.Color = RGB(0, 255, 0)
               End With
          Else
               With Range(Cells(Target.Row, "A"), Cells(Target.Row, "C"))
                    .Font.Color = RGB(0, 0, 0)
                    .Interior.ColorIndex = xlNone
               End With
          End If
          If UCase(Sexe) = "F" Then
               Range(Cells(Target.Row, "A"), Cells(Target.Row, "C")).Font.Color = RGB(255, 0, 255)
               Cells(Target.Row, "X").Font.Color = RGB(255, 0, 255)
          Else
               Range(Cells(Target.Row, "A"), Cells(Target.Row, "C")).Font.Color = RGB(0, 0, 0)
               Cells(Target.Row, "X").Font.Color = RGB(0, 0, 0)
          End If
     End If
Sortie:
     'Tri_Alpha_AC
     Application.EnableEvents = True
End Sub

Si vous arrivez à modifier ce code, pouvez-vous changer de couleurs pour la correction que je puisse copier la même façon de faire aux feuilles "Tir à 9 cibles" et "Tir à 13 cibles"

11jeux-penitentiaires-2025-3-3-1-2-1.zip (265.57 Ko)

mdp des feuilles ==> seb

mdp éditeur VBA ==> vodoraix

Merci bcp :-))))))))))))))

A bientôt

Le 28/08/2025 à 09:20

Bonjour,

Vous pouvez essayer ceci en supposant qu'il y ait au moins un nom en A3 :

DerLig_f2 = Range("A2").End(xlDown).Row
Le 28/08/2025 à 09:29

re,

au lieu de "'DerLig_f2 = Range("A" & Rows.Count).End(xlUp).Row"

i = Evaluate("min(IF((a3:a200="""")*(x3:x200=0),row(a3:a200),999))")     'première ligne avec A=vide et X=0
If i = 999 Then MsgBox "plage est pleine": Exit Sub
DerLig_f2 = i - 1                  'dernière ligne plein = ligne précédente

Edit: Salut Saboh16712

Le 28/08/2025 à 18:48

Bonsoir Saboh12617 & BsAlv, merci beaucoup pour votre aide :-))))))))))))))))))))))

Saboh12617, il manquait le cas des lignes vides et de bien encadrer mes 200 lignes, je crois...

BsAlv, j'ai même réussi à adapter ton code pour les 2 autres feuilles "9 cibles" & "13 cibles", c'est nickel !!!!!!!!!!!!!!! :-)))))))))))))))

Merci beaucoup :-))))))))))))))

J'ai ouvert un autre sujet à l'instant qui s'appelle "Supprimer des lignes VBA qui ne sont plus adaptées"

C'est pour adapter ton code VBA, BsAlv ;-))))

Rechercher des sujets similaires à "rectifier insertions donnees tableau"