Modification de code

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
luke3300

luke3300

XLDnaute Impliqué
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

Discussions similaires

Nicolas JACQUIN
  • Question
XL 2021 Création et adaptation barre de progression
2 3
Réponses
44
Affichages
892
Tartine
T
D
  • Résolu(e)
XL 2021 arrondi nombre de jours
Réponses
6
Affichages
424
Did25
D
G
  • Question
Microsoft 365 Export données
Réponses
4
Affichages
356
GClaire
G
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
773
Nicolas JACQUIN
Nicolas JACQUIN
Z
  • Résolu(e)
Microsoft 365 Problème de combinaison entre fonctions "If Then Else" et "SelectCase"
Réponses
11
Affichages
458
Zonmé
Z
lynyrd
  • Question
XL 2019 code pour tous les disques
Réponses
3
Affichages
409
AtTheOne
AtTheOne
M
  • Question
Microsoft 365 Erreur sur mon Code VBA
Réponses
2
Affichages
261
Gégé-45550
Gégé-45550
C
  • Question
XL 2021 Problème de remplissage d'une colonne conditionné à d'autres valeurs
Réponses
2
Affichages
261
CathyLD
C
C
  • Résolu(e)
XL 2016 Répartir dans des Groupes d'Effectifs Aléatoires ... mais pas trop
Réponses
2
Affichages
167
crocrocro
C
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
1 K
thivame
T

Membres actuellement en ligne

10 membres et 82 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 144
Messages
2 106 361
Membres
109 564
dernier inscrit
db974run