Modification de code

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion luke3300
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
luke3300

luke3300

XLDnaute Impliqué
Bonsoir le forum,

le code suivant me détecte des données manquntes dans un tableau suivant une colonne de "services" défini de la manière suivante: 1 lettre + chiffre(s) (ex: J103).

Code: 
Sub Detecte_NC()
    Dim Compteur As Long, Compteur2 As Long, Colonne_Test As Integer
    Dim Tab_Sces() As String, Nbr_Sces As Integer, Test As Boolean
    Dim Msg_String(1 To 2) As String
    Dim Premiere_Ligne_Titulaires As Long, Derniere_Ligne_Titulaires As Long
    Dim Premiere_Ligne_Remplacants As Long, Derniere_Ligne_Remplacants As Long
    
    'Définition des lignes à tester
    Premiere_Ligne_Titulaires = 14
    Derniere_Ligne_Titulaires = 73
    Premiere_Ligne_Remplacants = 11
    Derniere_Ligne_Remplacants = 60
    
    'les services du samedi
    Erase Tab_Sces
    Nbr_Sces = 13
    ReDim Preserve Tab_Sces(1 To 2, 1 To Nbr_Sces) As String
    Tab_Sces(1, 1) = "JS9": Tab_Sces(1, 2) = "JS13": Tab_Sces(1, 3) = "JS20"
    Tab_Sces(1, 4) = "JS21": Tab_Sces(1, 5) = "JS22": Tab_Sces(1, 6) = "JS23"
    Tab_Sces(1, 7) = "HS6": Tab_Sces(1, 8) = "LS1": Tab_Sces(1, 9) = "LS2"
    Tab_Sces(1, 10) = "JS103": Tab_Sces(1, 11) = "JS105": Tab_Sces(1, 12) = "JS202"
    Tab_Sces(1, 13) = "JS205":
                
    Application.ScreenUpdating = False
    Colonne_Test = ActiveCell.Column
    
    Select Case Range("A6").Offset(0, Colonne_Test - 1).Value
        Case Is = "L", "M", "J", "V"
            With Sheets(1)
                Erase Tab_Sces
                Nbr_Sces = 0
                For Compteur = Premiere_Ligne_Titulaires To Derniere_Ligne_Titulaires 'lignes testées
                    If .Range("B" & Compteur).Value > "" Then
                        Nbr_Sces = Nbr_Sces + 1
                        ReDim Preserve Tab_Sces(1 To 2, 1 To Nbr_Sces) As String
                        Tab_Sces(1, Nbr_Sces) = UCase(Left(.Range("B" & Compteur).Value, 1) & CInt(Right(.Range("B" & Compteur).Value, Len(.Range("B" & Compteur).Value) - 1)))
                        If .Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value = "X" Then Tab_Sces(2, Nbr_Sces) = Tab_Sces(2, Nbr_Sces) & "X"
                    End If
                Next Compteur
                For Compteur = Premiere_Ligne_Titulaires To Derniere_Ligne_Titulaires 'lignes testées
                    If .Range("B" & Compteur).Value > "" And Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) > 1 Then
                        If IsNumeric(Right(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) - 1)) Then
                            For Compteur2 = 1 To Nbr_Sces
                                If UCase(Left(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, 1) & CDec(Right(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) - 1))) = Tab_Sces(1, Compteur2) Then
                                    Tab_Sces(2, Compteur2) = Tab_Sces(2, Compteur2) & "X"
                                End If
                            Next Compteur2
                        End If
                    End If
                Next Compteur
            End With
            With Sheets(2)
                For Compteur = Premiere_Ligne_Remplacants To Derniere_Ligne_Remplacants 'lignes testées
                    If .Range("A" & Compteur).Value > "" And Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) > 1 Then
                        If IsNumeric(Right(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) - 1)) Then
                            For Compteur2 = 1 To Nbr_Sces
                                If UCase(Left(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, 1) & CDec(Right(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) - 1))) = Tab_Sces(1, Compteur2) Then
                                    Tab_Sces(2, Compteur2) = Tab_Sces(2, Compteur2) & "X"
                                End If
                            Next Compteur2
                        End If
                    End If
                Next Compteur
            End With
            Test = False
            For Compteur2 = 1 To Nbr_Sces
                Select Case Len(Tab_Sces(2, Compteur2))
                    Case Is = 0
                        Test = True
                        Msg_String(1) = Msg_String(1) & " " & Tab_Sces(1, Compteur2)
                    Case Is > 1
                        Test = True
                        Msg_String(2) = Msg_String(2) & " " & Tab_Sces(1, Compteur2)
                    Case Else
                End Select
            Next Compteur2
            If Test = False Then
                MsgBox "Jour: " & ActiveSheet.Range("B6").Offset(0, Colonne_Test - 2).Value _
                & " " & ActiveSheet.Range("B6").Offset(1, Colonne_Test - 2).Value & Chr(10) _
                & "Aucune erreur détectée.", vbOKOnly + vbExclamation
            Else
                MsgBox "Jour: " & ActiveSheet.Range("B6").Offset(0, Colonne_Test - 2).Value _
                & " " & ActiveSheet.Range("B6").Offset(1, Colonne_Test - 2).Value & Chr(10) _
                & "service(s) non affecté(s):" & Chr(10) & Msg_String(1) _
                & Chr(10) & Chr(10) & "Service(s) affecté(s) plus d'une fois:" & _
                Chr(10) & Msg_String(2), vbOKOnly + vbExclamation
            End If
        Case Is = "S"
            With Sheets(1)
                For Compteur = Premiere_Ligne_Titulaires To Derniere_Ligne_Titulaires 'lignes testées
                    If .Range("B" & Compteur).Value > "" And Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) > 1 Then
                        If IsNumeric(Right(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) - 2)) Then
                            For Compteur2 = 1 To Nbr_Sces
                                If UCase(Left(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, 2) & CDec(Right(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) - 2))) = Tab_Sces(1, Compteur2) Then
                                    Tab_Sces(2, Compteur2) = Tab_Sces(2, Compteur2) & "X"
                                End If
                            Next Compteur2
                        End If
                    End If
                Next Compteur
            End With
            With Sheets(2)
                For Compteur = Premiere_Ligne_Remplacants To Derniere_Ligne_Remplacants  'lignes testées
                    If .Range("A" & Compteur).Value > "" And Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) > 1 Then
                        If IsNumeric(Right(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) - 2)) Then
                            For Compteur2 = 1 To Nbr_Sces
                                If UCase(Left(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, 2) & CDec(Right(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value, Len(.Range("B" & Compteur).Offset(0, Colonne_Test - 2).Value) - 2))) = Tab_Sces(1, Compteur2) Then
                                    Tab_Sces(2, Compteur2) = Tab_Sces(2, Compteur2) & "X"
                                End If
                            Next Compteur2
                        End If
                    End If
                Next Compteur
            End With
            Test = False
            For Compteur2 = 1 To Nbr_Sces
                Select Case Len(Tab_Sces(2, Compteur2))
                    Case Is = 0
                        Test = True
                        Msg_String(1) = Msg_String(1) & " " & Tab_Sces(1, Compteur2)
                    Case Is > 1
                        Test = True
                        Msg_String(2) = Msg_String(2) & " " & Tab_Sces(1, Compteur2)
                    Case Else
                End Select
            Next Compteur2
            If Test = False Then
                MsgBox "Jour: " & ActiveSheet.Range("B6").Offset(0, Colonne_Test - 2).Value _
                & " " & ActiveSheet.Range("B6").Offset(1, Colonne_Test - 2).Value & Chr(10) _
                & "Aucune erreur détectée.", vbOKOnly + vbExclamation
            Else
                MsgBox "Jour: " & ActiveSheet.Range("B6").Offset(0, Colonne_Test - 2).Value _
                & " " & ActiveSheet.Range("B6").Offset(1, Colonne_Test - 2).Value & Chr(10) _
                & "Service(s) non affecté(s):" & Chr(10) & Msg_String(1) _
                & Chr(10) & Chr(10) & "Service(s) affecté(s) plus d'une fois:" & _
                Chr(10) & Msg_String(2), vbOKOnly + vbExclamation
            End If
        Case Is = "D"
            MsgBox "Hé Ho? ça va pas la tête ... c'est dimanche là!!!", vbInformation
        Case Else
    End Select
'
' Detecte_NC Macro
' Macro enregistrée le 12/04/2005 par PETRE Stéphane
'
End Sub

J'aimerais cependant modifier l'intitulé des "services" et utiliser 2 lettres + chiffre(s) comme JB002.

Lorsque je le modifie dans mon fichier, le déboguage se fait et il me met cette ligne en jaune:

Tab_Sces(1, Nbr_Sces) = UCase(Left(.Range("B" & Compteur).Value, 1) & CInt(Right(.Range("B" & Compteur).Value, Len(.Range("B" & Compteur).Value) - 1)))

Ma question est la suivante: que dois-je modifier dans le code pour qu'il accepte la prise en charge des "services" nommés par 2 lettres et un ou des chiffres?

Le fichier que j'utilise est Ce lien n'existe plus

D'avance un grand merci et bonne soirée àtout le monde.
 
Trier par date Trier par votes
Re : Modification de code

Bonjour Yeahou et le forum,

et bien voilà, j'ai pris un peu de temps pour tester tout ça et je ne peux dire qu'une chose ... épatant!

Merci beaucoup Yeahou pour ta patience et pour m'avoir consacré de ton temps et de ton talent.

Grâce à toi, je vais réduire le risque d'erreur dans mon boulot et accélérer un peu la gestion du personnel.

Encore un grand merci et bonne journée à tout le monde.
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
334
Gestionnaire_rh
G
M
  • Question Question
XL 2021 macro VBA
Réponses
4
Affichages
148
ManuEven
M
K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
99
KRUG WOO
K
C
  • Question Question
Microsoft 365 worksheet_change
2
Réponses
29
Affichages
250
CortoXls
C
klin89
  • Question Question
Microsoft 365 Méthode Evaluate pour se dispenser d'une boucle imbriquée
Réponses
14
Affichages
396
patricktoulon
patricktoulon
G
  • Question Question
XL 2021 Macro pour changer les titres de fichier d'archive
Réponses
3
Affichages
98
fanch55
fanch55
Nicolas JACQUIN
  • Question Question
XL 2021 Création et adaptation barre de progression
2 3
Réponses
44
Affichages
1 K
Tartine
T
D
  • Résolu(e)
XL 2021 arrondi nombre de jours
Réponses
6
Affichages
509
Did25
D
jeanmi
  • Résolu(e)
XL 2010 amélioration code
Réponses
3
Affichages
95
jeanmi
jeanmi
G
  • Question Question
Microsoft 365 Export données
Réponses
4
Affichages
503
GClaire
G
G
  • Question Question
Microsoft 365 Rendre dynamique un array (Résolu)
Réponses
7
Affichages
178
GClaire
G
A
  • Question Question
VBA qui fonctionnait avant, mais ne fonctionne plus avec le 64 bits
Réponses
2
Affichages
219
patricktoulon
patricktoulon
Nicolas JACQUIN
  • Question Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
J
  • Question Question
Microsoft 365 Probléme VBA
Réponses
8
Affichages
233
jalaba
J
lynyrd
  • Question Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
599
AtTheOne
AtTheOne
N
  • Résolu(e)
Microsoft 365 Modification impossible d'une TextBox
2 3 4
Réponses
56
Affichages
1 K
NONO14
N
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
571
Zonmé
Z
N
  • Résolu(e)
Microsoft 365 Code fonction pour création code aléatoire
2 3
Réponses
32
Affichages
704
NONO14
N
E
  • Résolu(e)
Microsoft 365 Reduire Temps Execution Code
Réponses
5
Affichages
82
eric72
E
C
  • Question Question
XL 2021 VBA excel
Réponses
4
Affichages
79
CDALE
C
Retour