[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.

luke3300 · 19 Décembre 2013

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

Tant que j'y suis Yeahou, et si ce n'est pas trop abuser, serait-il possible que la macro ne base sa détection que sur les valeurs de la colonne B et les "X"?
Il serait nécessaire que je filtre les données de la colonne B mais dans ce cas, la macro détecte malgré tout toutes les données de cette colonne sans tenir compte des données qui ne s'affichent pas ...

Merci d'avance.

Bernard_XLD · 20 Décembre 2013

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

Bonjour

mets une feuille exemple avec ce que tu veux que je comprenne bien la fonctionnalité désirée

@+

luke3300 à dit:
Tant que j'y suis Yeahou, et si ce n'est pas trop abuser, serait-il possible que la macro ne base sa détection que sur les valeurs de la colonne B et les "X"?
Il serait nécessaire que je filtre les données de la colonne B mais dans ce cas, la macro détecte malgré tout toutes les données de cette colonne sans tenir compte des données qui ne s'affichent pas ...

Merci d'avance.

Bernard_XLD · 20 Décembre 2013

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

Re

voila déjà la première modif à tester

@+

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
        'Liste des services
        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
        'Test
        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
 '
 End Sub

luke3300 · 20 Décembre 2013

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

Et bien Yeahou ... encore une fois, Bravo! Tout nickel

Merci beaucoup.
Pour ma seconde demande, je mets un fichier exemple en pièce jointe pour mieux comprendre ... encore merci car c'est du super boulot.
Bonne soirée à tous.

Bernard_XLD · 22 Décembre 2013

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

Bonjour Luke

Voila qui devrait correspondre si je t'ai bien compris

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 = 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
        'Liste des services
        For Compteur = Premiere_Ligne_Titulaires To Derniere_Ligne_Titulaires 'lignes testées
            If .Range("B" & Compteur).Value > "" And Not (Intersect(.Range("B" & Compteur), .Range("B" & Premiere_Ligne_Titulaires & ":B" & Derniere_Ligne_Titulaires).SpecialCells(xlCellTypeVisible)) Is Nothing) = True 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
        'Test
        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
 '
 End Sub

luke3300 · 24 Décembre 2013

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

Que dire sinon ... une fois de plus "merci"

Splendide! C'est exactement ce que je recherchais.
Excellente fête de Noël à toi Yeahou ainsi qu'au forum.
Merci d'être là car vous m'apportez une aide considérable.
Très bonne journée.

PS: je continue d'agrémenter mon fichier de travail donc je reviendrais très certainement vers vous tous dans les jours qui viennent. D'ici là, portez-vous bien.

luke3300 · 8 Octobre 2016

Bonsoir le forum,

Le code formidable que Yeahou avait concocté me joue des tours et me détecte un débogage de script à la ligne suivante:

Code:

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

Pourtant je n'ai rien changé depuis la dernière utilisation il y a quelques jours c'est juste que je viens de passer à Excel 2013 et 2016 et depuis ... il me met ça en erreur et impossible d'avancer.

Merci pour votre aide.

luke3300 · 8 Octobre 2016

Bon ben désolé du dérangement mais c'est moi qui avait fait une fausse manoeuvre et j'en suis désolé.
Bonne soirée au forum.

Effectuez une recherche sur Excel Downloads...

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

luke3300

XLDnaute Impliqué

Pièces jointes

Bernard_XLD

luke3300

XLDnaute Impliqué

Bernard_XLD

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

luke3300

XLDnaute Impliqué

Pièces jointes

Bernard_XLD

XLDnaute Barbatruc

luke3300

XLDnaute Impliqué

luke3300

XLDnaute Impliqué

luke3300

XLDnaute Impliqué

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums