[VBA] Adapter un code VBA pour étendre les critères de recherche

luke3300 · 13 Septembre 2013

Bonjour le forum,

J'ai un fichier avec une macro qui m'aide à détecter des "X" (qui équivalent aux valeurs de la colonne B) dans les différentes colonnes.
J'aimerais que cette macro détecte en plus des "X", les intitulés de la colonne B.
J'essaye sans succès depuis un bout de temps mais je désespère ... il me semble que cela devrait être possible pourtant.
Pourriez-vous m'aider s'il vous plait?

D'avance merci et un excellent w-e à tous.

apnart · 13 Septembre 2013

Re : (VBA) Adaptation de code

Ton fichier est protégé par mot de passe

luke3300 · 13 Septembre 2013

Re : (VBA) Adaptation de code

Merci de me le signaler apnart.
Le mot de passe est: MERCI

luke3300 · 13 Septembre 2013

Re : (VBA) Adaptation de code

Voilà, j'ai retiré le mot de passe

luke3300 · 14 Septembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

En explication complémentaires de ce que j'aimerais obtenir, c'est que lorsque je clique sur mon bouton "Détection" (en haut à G), la macro me détecte dans la colonne choisie, si tous les intitulés repris en B sont comptabilisés soit via une X (pour le personnel titulaire présent) soit par un intitulé (par exemple J201) que l'on retrouve dans la colonne B.
Petite explication sur la macro: celle-ci détecte si tous (on va dire) les services repris en colonne B sont assurés. Si ce n'est pas le cas, un messagebox me prévient que des services non assurés et ceux qui ont été assignés plusieurs fois.
Actuellement pour l'onglet "Titulaires", la macro ne tient compte que des X et pas des intitulés comme les J201, J202, etc ... repris en colonne B. Mais il le fait pour l'autre onglet masqué (Remplaçants).
Merci pour votre aide

luke3300 · 15 Septembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Bon ben voilà ... j'ai cherché encore et encore et je suis parvenu à obtenir en grande partie ce que je voulais ... car pour le samedi, la macro ne détecte pas plus loin que le nombre d'intitulé qu'il y a dans la colonne B. Hors j'aimerais qu'elle détecte jusqu'à la ligne 200.
Quelqu'un peut-il me dire ce que je dois modifier dans le code ci-dessous pour que le samedi, la détection se fasse jusqu'à la ligne 200 et ne se limite plus à rechercher uniquement jusqu'à heuteur de la dernière valeur de la colonne B? Il me semble que ce qu'il faut modifier est dans la partie entre les *****???

Voici mon 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 = 8
Derniere_Ligne_Titulaires = 200
Premiere_Ligne_Remplacants = 10
Derniere_Ligne_Remplacants = 75

'les services du samedi
Erase Tab_Sces
Nbr_Sces = 3
ReDim Preserve Tab_Sces(1 To 2, 1 To Nbr_Sces) As String
Tab_Sces(1, 1) = "JS202": Tab_Sces(1, 2) = "JS204": Tab_Sces(1, 3) = "JS207"

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
For Compteur = Premiere_Ligne_Titulaires To Derniere_Ligne_Titulaires '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
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
'
'
End Sub

Merci d'avance et bon dimanche.

Bernard_XLD · 16 Septembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Bonjour Luke3300

Je ne me souvenais plus de ce code, je regarderai ça dans la journée.

Cordialement

luke3300 · 16 Septembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Merci d'avance Yeahou, il faut dire que c'est normal ... il date de 2007 ou 2008 et depuis lors tu as du en faire des tonnes

Bernard_XLD · 17 Septembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Bonjour luke3300, le forum

dis moi si c'est ce que tu voulais.

Cordialement

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 = 8
    Derniere_Ligne_Titulaires = 200
    Premiere_Ligne_Remplacants = 10
    Derniere_Ligne_Remplacants = 75
    
    'les services du samedi
    Erase Tab_Sces
    Nbr_Sces = 3
    ReDim Preserve Tab_Sces(1 To 2, 1 To Nbr_Sces) As String
    Tab_Sces(1, 1) = "JS202": Tab_Sces(1, 2) = "JS204": Tab_Sces(1, 3) = "JS207"
    
                
    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 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 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

luke3300 · 18 Septembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Bonjour Yeahou, le forum,

je viens de tester le code ci-dessus mais il bloque toujours au même endroit que l'autre.
En fait, si tu regardes sur le fichier "test" que j'ai joint à mon message d'origine, tu verras que les données sont complétées en colonne B jusqu'à la ligne 17 et lorsque je lance la détection le samedi (en G), elle ne tient pas compte des données entrées à partir de la ligne 17. Ce que j'aimerais, c'est qu'elle aille jusque la ligne 200 ou qu'elle soit dynamique en s'adaptant au nombre de lignes utilisées. En ce qui concerne l'onglet "remplaçants", elle prend bien tout en compte, de la 1ère à la dernière ligne.
Encore merci pour ton aide et ta patience.
Très bonne journée à tous.

Bernard_XLD · 18 Septembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Bonjour

cela fonctionne chez moi, en exemple, quand je rentre js202 en g26 et g27, la détection se fait correctement quand je lance la macro detecte_nc
je t'ai remis le fichier modifié en pièce jointe

@+

luke3300 · 20 Septembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Bonjour Yeahou, le forum,
Après tests approfondis, je confirme que cela fonctionne à merveille

Merci 1000 fois Yeahou, grâce à toi mon fichier est 100% opérationnel.

Excellente journée à tous ... et encore merci.

luke3300 · 16 Décembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Bonsoir le forum,

J'ai un petit souci avec le code que Yeahou m'a superbement concocté

Je l'ai adapté (avec mes moyens et connaissances) un peu aux besoins mais il me détecte cette fois les services J... en double lorsqu'ils sont mis à la place d'une "X" dans les colonnes (à partir de C) en face de ceux qui ont un intitulé en colonne B. Pour les autres colonnes (sans énoncés en colonne B) tout est nickel.

Je joint une capture pour mieux comprendre ... ainsi que le 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 = 8
Derniere_Ligne_Titulaires = 200
Premiere_Ligne_Remplacants = 10
Derniere_Ligne_Remplacants = 75

'les services du samedi
Erase Tab_Sces
Nbr_Sces = 21
ReDim Preserve Tab_Sces(1 To 2, 1 To Nbr_Sces) As String
Tab_Sces(1, 1) = "JS2": Tab_Sces(1, 2) = "JS11": Tab_Sces(1, 3) = "JS13"
Tab_Sces(1, 4) = "JS16": Tab_Sces(1, 5) = "JS21": Tab_Sces(1, 6) = "JS22"
Tab_Sces(1, 7) = "JS24": Tab_Sces(1, 8) = "JS26": Tab_Sces(1, 9) = "JS36"
Tab_Sces(1, 10) = "JS38": Tab_Sces(1, 11) = "JS39": Tab_Sces(1, 12) = "JS42"
Tab_Sces(1, 13) = "JS48": Tab_Sces(1, 14) = "JS49": Tab_Sces(1, 15) = "JS52"
Tab_Sces(1, 16) = "CS1": Tab_Sces(1, 17) = "CS2": Tab_Sces(1, 18) = "JS304"
Tab_Sces(1, 19) = "JS305": Tab_Sces(1, 20) = "JS306": Tab_Sces(1, 21) = "JS307"

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
For Compteur = Premiere_Ligne_Titulaires To Derniere_Ligne_Titulaires '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
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 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
'
End Sub

Merci d'avance pour votre aide précieuse et bonne soirée à tous.

Bernard_XLD · 18 Décembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Salut Luke

j'avais loupé ton message, je regarde

@+

luke3300 · 19 Décembre 2013

Re : [VBA] Adapter un code VBA pour étendre les critères de recherche

Merci Yeahou, très bonne journée à tous.

[VBA] Adapter un code VBA pour étendre les critères de recherche

XLDnaute Impliqué

Pièces jointes

XLDnaute Occasionnel

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

Discussions similaires

Partager cette page

Statistiques des forums