Alléger le VBA car beaucoup de requêtes MFC à la place

Le 02/10/2025 à 06:50

Bonjour,

J'avais plusieurs complications pour adapter le VBA écrit par un spécialiste du code à certaines exigences ou nouveaux fonctionnements de mes tableaux. Avec des MFC, ça sera plus simple que le VBA pour moi au niveau de la maintenance des tableaux.

Ainsi j'aurais besoin de supprimer certaines lignes du VBA car, ne sachant pas modifier celui-ci, "Doux Rêveur" a réussi à résoudre plusieurs de mes nouveaux sujets.

En effet, VBA et MFC font désormais doublons sur plusieurs points.

Pour parfaire mes MFC, il faudrait peut-être réaliser avant une dernière action MFC ==>

En surbrillance verte, se retrouvent les nouveaux noms qu'on écrit à la main dans le tableau des scores "TBL_5Ateliers" car ne se trouvant pas dans le tableau pré-listé dans les colonnes de Z à AB.

Voici le VBA à modifier si vous êtes à l'aise avec le code :

'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
          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
          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

J'aurais besoin de savoir quelles sont les lignes précisément à supprimer. De cette façon, je pourrai modifier les 2 autres feuilles (9 & 11 cibles) pour essayer de faire pareil.

Pour info, la surbrillance verte c'est cette couleur ==>

.Interior.Color = RGB(0, 255, 0)

Que pensez-vous de tout ça svp ?

Pas trop dur à modifier ?

9jeux-penitentiaires-2025-6-5-avec-medailles-petanque.zip (310.32 Ko)

Sur le bouton "Débloquer ou Quitter", tapez vodoraix pour tt débloquer.

Et mot de passe pour débloquer les feuilles ==> seb

Merci beaucoup de vous intéresser à ce sujet.

Bonne journée

Le 02/10/2025 à 09:38

Bonjour, Désolé

Erreur de post

Le 02/10/2025 à 10:11

bonjour vodoraix, Joco7915,

un essai, moi, je n'avais écrit ces macros, j'utilise toujours le TS comme source.

9jeux-penitentiaires-2025-6-5-avec-medailles-petanque.zip (299.90 Ko)

Le 02/10/2025 à 21:17

Bonsoir Bart' et merci beaucoup

Désolé, je rentre tout juste chez moi et je viens à peine de voir ton travail...

C'est quoi le TS, comme tu écris ?

Super, tu as allégé le code VBA de façon XXL ==> Merci beaucoup

J'ai essayé de modifier le MFC mais sans réussite :

1) Comment obligé qu'il n'y ait que H ou F dans "sexe" et rien d'autre, ni du vide ?

2) J'ai pas réussi à mettre le texte en rose quand c'est une Femme dont les cellules sont en surbrillance verte.

3) Tout comme pour la surbrillance jaune, pour les nouveaux sportifs non présents dans la colonne Z donc en surbrillance verte, j'aimerais, s'ils font plusieurs essais qu'il n'y ait que le premier en surbrillance verte et pas les autres...

Pas trop compliqué à faire ?

Il faudra que j'arrive à reproduire tes changements dans le VBA de la feuille "5 ateliers" pour les appliquer dans les 2 autres feuilles "9 & 11 cibles"

MErci beaucoup pour tout, Bart'

8jeux-penitentiaires-2025-6-6-avec-medailles-petanque.zip (302.86 Ko)

Bonne soirée

à bientôt

Le 03/10/2025 à 19:43

5jeux-penitentiaires-2025-6-6-avec-medailles-petanque.zip (300.59 Ko)

Le 03/10/2025 à 20:06

Bonsoir Bart' et merci pour ton aide

Le tableau devient tout noir et j'ai un bug

Bonne soirée

à bientôt...

Le 04/10/2025 à 01:47

re,

oei, je vois que j'ai oublié ces 2 lignes avec "if i=20 then stop" (une en jaune et l'autre 10 lignes en dessous) que vous pouvez supprimer et puis tu sors VBA et tu pousse F9 pour récalculer.

Le 04/10/2025 à 08:42

Coucou Bart', ça marche impec, merci beaucoup

J'ai juste le premier de la liste alphabétique ABOUDOU qui ne s'importe pas dans les colonnes Z à AB.

J'ai modifié le code (y'avait écrit 6, j'ai mis 5) et alleluiahhh, ça marche...

T'es pas fier de moi ?

Je vais essayer de tout adapter sur les feuilles 9 & 11 cibles...

Juste, feuille Blad2, j'en ai encore besoin ou je peux supprimer ?

Encore milles mercis mon champion

Bon w.e. Bart'

Le 04/10/2025 à 11:13

re,

oui, tu peux supprimer cette feuille "Blad2", mais aussi module15 (macro3&4), peut-être aussi module6 (macro1, ce n'est pas la mienne) et module12 (macro2)

La colonne Y = MFC, sert pour les MFCs et important pour sa fonctionnement, elle n'est pas dans le tableau structuré. Elle est là pour simplifier quelques formules MFC, mais autrement VBA n'est pas utilisé pour les couleurs.

Sub MFC_5_ateliers() >>>> elle efface les MFCs du TS , désactiver !!!

C'est plus pratique de tout mettre dans des tableaux structurés, ils mémorisent leurs MFCs, leur quadrillage, leur formules, ... que de réinventer l'eau chaude.

Le 04/10/2025 à 14:47

Trop bien pour toutes tes explications !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

J'ai tout bien fait comme tu as expliqué mais j'ai pas osé pour module 6 (macro 1) car il me semble que c'était Galopin01 qui me l'avait écrite. Si tu es certain je fais, sinon je lui demande car g rien compris au code

Sub Macro1()
     '
     ' Macro1 Macro
     '

     '
     Range("A10:BO47").Select
     Selection.ListObject.ListRows.Add (6)
     Selection.ListObject.ListRows.Add (7)
     Selection.ListObject.ListRows.Add (8)
     Selection.ListObject.ListRows.Add (9)
     Selection.ListObject.ListRows.Add (10)
     Selection.ListObject.ListRows.Add (11)
     Selection.ListObject.ListRows.Add (12)
     Selection.ListObject.ListRows.Add (13)
     Selection.ListObject.ListRows.Add (14)
     Selection.ListObject.ListRows.Add (15)
     Selection.ListObject.ListRows.Add (16)
     Selection.ListObject.ListRows.Add (17)
     Selection.ListObject.ListRows.Add (18)
     Selection.ListObject.ListRows.Add (19)
     Selection.ListObject.ListRows.Add (20)
     Selection.ListObject.ListRows.Add (21)
     Selection.ListObject.ListRows.Add (22)
     Selection.ListObject.ListRows.Add (23)
     Selection.ListObject.ListRows.Add (24)
     Selection.ListObject.ListRows.Add (25)
     Selection.ListObject.ListRows.Add (26)
     Selection.ListObject.ListRows.Add (27)
     Selection.ListObject.ListRows.Add (28)
     Selection.ListObject.ListRows.Add (29)
     Selection.ListObject.ListRows.Add (30)
     Selection.ListObject.ListRows.Add (31)
     Selection.ListObject.ListRows.Add (32)
     Selection.ListObject.ListRows.Add (33)
     Selection.ListObject.ListRows.Add (34)
     Selection.ListObject.ListRows.Add (35)
     Selection.ListObject.ListRows.Add (36)
     Selection.ListObject.ListRows.Add (37)
     Selection.ListObject.ListRows.Add (38)
     Selection.ListObject.ListRows.Add (39)
     Selection.ListObject.ListRows.Add (40)
     Selection.ListObject.ListRows.Add (41)
     Selection.ListObject.ListRows.Add (42)
     Selection.ListObject.ListRows.Add (43)
     Range("AF23").Select
End Sub

Il ne faut pas effacer cette macro aussi ci-dessous ? Car la surbrillance verte, c'est fait pas la MFC...

A moins que ça gère ta colonne en "Y" mais je ne crois pas car pas vu de colonne Y dans ce code ==>

Sub MFC_5_ateliers_verte()
     Exit Sub
     Dim f2    As Worksheet
     Dim DerLig_f2 As Long
     Dim Plage_MFC_5_ateliers As Range
     Dim FC1   As FormatCondition
     Dim formuleMFC_5_ateliers As String

     Set f2 = Sheets("5 ateliers")
     DerLig_f2 = f2.Cells(f2.Rows.Count, "Z").End(xlUp).Row

     Set Plage_MFC_5_ateliers = f2.Range("A3:C" & DerLig_f2)
     Plage_MFC_5_ateliers.FormatConditions.Delete

     formuleMFC_5_ateliers = "=ET(A3<>"""";" & "SOMMEPROD((Z$2:Z" & DerLig_f2 & "=A3)*(AA$2:AA" & DerLig_f2 & "=B3)*(AB$2:AB" & DerLig_f2 & "=C3))=0)"

     Set FC1 = Plage_MFC_5_ateliers.FormatConditions.Add(Type:=xlExpression, Formula1:=formuleMFC_5_ateliers)
     FC1.Interior.Color = RGB(0, 255, 0)
     FC1.Font.Color = RGB(0, 0, 0)
End Sub

J'ai effacé, finalement, et pas désactivé Sub MFC_5_ateliers(). Car MFC fait le travail.

Merci beaucoup Bart'

Et de toute façon pour l'eau chaude, elle existe depuis la nuit des temps, elle est produite de manière naturelle dans les entrailles de la Terre. Et j'adore l'Islande, au passage, les numéros 1 de l'écologie

Bonne aprèm

Rechercher des sujets similaires à "alleger vba beaucoup requetes mfc place"