VBA : contrôle de références consécutives sans doublons

Bonjour tout le monde.

Après près de 6 mois sans poster (m'étant toujours débrouillé avec les réponses apportées ici et ailleurs), je reviens à la charge.

J'ai un fichier dont j'ai joint un exemple qui contient volontairement des erreurs.

La hauteur du tableau est variable, mais je la contrôle via un

Dim LastRow as Long
LastRow = Range("B1048576").End(xlUp).Row

J'ai plusieurs contrôles à faire, mais je bloque sur une partie, qui, cela va de soit, n'est pas la plus simple a expliquer.

Cela se passe dans les colonnes "B-C-D-E", à partir de la ligne 11

Pour "faciliter" le codage, il y a des lignes vides, de nombre variable (dans l'exemple il n'y que des groupes de 2 lignes vides, mais ce n'est que pur hasard) que je ne peux retirer

=> le "quattuor" doit être unique

Dans l'exemple :

• -> ligne 26, 29 et 34 j'ai 2-1-B-10 , ce qui est anormal
• -> lignes 22 et 56 j'ai 2-1-C-10 ce qui est anormal
• -> lignes 46 et 69, j'ai 2-1-C-2 ce qui est anormal

Jusque là, j'arrive à m'en sortir en traitant un relevé de doublons.

A noter que les doublons ne doivent pas arrêter le contrôle, mais être signalés pour être rectifiés manuellement.

Je reporte les valeurs dans une cellule de la même ligne et je traite ces cellules pour afficher les doublons

Il doit y avoir plus simple, mais j'ai fait avec mes (très) maigres connaissances

Dim i As Integer
For i = 11 to LastRow
     If Range("B" & i).Value > 0 Then
          Range("Z" & i).FormulaR1C1 = Range("B" & i).Value & " - " & Range("C" & i).Value & " - " & Range("D" & i).Value & " - " & Range("E" & i).Value
     Else
          Range("Z" & i).FormulaR1C1 = ""
     End If
Next

'Verification d'absence de doublon de position
     Set Plage = Range("Z11:Z" & LastRow)
     For Each Cel In Plage
          If Application.CountIf(Plage, Cel.Value) > 1 Then
               Cel.Select
               Selection.Activate
               Cells(ActiveCell.Row, 1).Interior.ColorIndex = 6
               Cells(ActiveCell.Row, 27).Value = Application.CountIf(Plage, Cel.Value)
               MsgBox "Une position occupée plus d'une fois a été trouvée" & Chr(10) & "Veuillez la noter, afin de la rectifier à la fin du contrôle" & Chr(10) & Chr(10) & "Position (Baie - Tiroir - Module - N° Fibre) : " & Chr(10) & Cel.Value & Chr(10) & "Ligne " & ActiveCell.Row
          Else
              Cel.Select
              Selection.Activate
              If Selection <> "" Then
                   Cells(ActiveCell.Row, 25).FormulaR1C1 = "Ok"
                   Cells(ActiveCell.Row, 25).Interior.ColorIndex = 4
              Else
                   Cells(ActiveCell.Row, 25).Interior.Pattern = xlNone
              End If
          End If
    Next Cel

J'espère que jusque là tout est "clair"

A présent la partie ou je bloque.

Les valeurs contenues dans ce "quatuor" doivent avoir une suite "logique"et si ce n'est pas la cas, une "alerte doit être posée (msg puis mise en valeur par couleur...)

Suite "Normale"

2-1-A-1 / 2-1-A-2 / 2-1-A-3 / 2-1-A-4 / 2-1-B-7 / 2-1-B-8 / 2-1-B-9 / 2-1-B-10 / 2-1-B-11 / 2-1-C-5 / 2-1-C6 / 2-1-C-7 / 2-1-C-8 ....

Suite "Erronée"

2-1-A-1 / 2-1-A-2 / 2-1-A-3 / 2-1-A-4 / 2-1-B-7 / 2-1-A-5 / 2-1-A-6 / 2-1-B-6 / 2-1-B-9 / 2-1-C-4 / 2-1-B-10 / 2-1-B-11 / 2-1-C-5 / 2-1-C6 / 2-1-C-7 / 2-1-C-8 / 2-1-D-1 / 2-1-D-2 / 2-1-C-9 / 2-1-C-10 / 2-1-C-11

Dans le fichier en exemple, il y a :

ligne 11 : 2-1-A-1

ligne 12 : 2-1-A-2

ligne 13 : 2-1-A-3

ligne 14 : 2-1-B-4

ligne 15 : vide

ligne 16 : vide

ligne 17 : 2-1-A-5

ligne 18 : 2-1-A-6

=> la ligne 14 (B16:E16) est une anomalie vue la valeur précédente et vue les 2 valeurs suivantes

En résumé, une fois qu'une valeur est augmentée, il est anomal de revenir en arrière, pour reprendre le cours initial

Je dis bien anormale, et non pas interdit (les lois de raccordement étant impénétrable)

La colonne B sera toujours un chiffre, égale à 2

La colonne C sera toujours un chiffre compris entre 1 et 3

La colonne D sera toujours une lettre, de A à D

La colonne E sera toujours une chiffre compris entre 1 et 24,

En espérant ne pas être trop brouillon

Je remercie d'avance touts les membre qui voudrons bien m'aider à faire ce complément de macro

Bonjour,

j'ai préféré faire à ma manière dès le début plutot que de reprendre ton code.

En fin de proc un code ano est mis dans le tableau ano()

Codes anos :

- : une saisie au moins est manquante, mais pas les 4

<C : régression en colonne C, idem pour les autres colonnes

x : nombre de 1 à x, n° de doublon

Les anos sont prioritaires dans cet ordre. Un <C n'écrasera pas un "-"

Ce qui explique que tu ne vois que 2 doublons/3 pour le n°1, et un seul doublon n°2. Les autres en ligne 34 et 69 ont déjà l'ano <E. La résolution de ces anos résoudra sans doute les doublons, du moins en partie pour le n°1.

La colonne B sera toujours un chiffre, égale à 2

La colonne C sera toujours un chiffre compris entre 1 et 3

La colonne D sera toujours une lettre, de A à D

La colonne E sera toujours une chiffre compris entre 1 et 24,

Je controle 2 en B, je te laisse ajouter les autres controles si besoin.

J'ai collé ano() en A. Tu peux faire des MFC dessus, ou bien t'en servir en fin de code pour faire un autre traitement.

eric

PS : je n'avais pas preté attention au c minuscule en D22 et ne converti pas avec Ucase pour les tests. Sois tu complètes le code, soit tu mets des majuscules partout

Bonjour le fil, bonjour le forum,

Une autre proposition très capillotractée j'en conviens... Clique sur le bouton Doublons & Anomalies...

La macro crée et utilise un onglet Travail (qui sera supprimé à la fin). Elle commence par repérer les doublons puis s'arrête pour laisser à l'utilisateur la possibilité de rectifier les erreurs des doublons (les colonnes inutiles sont masquées) .

Une relance de la macro permet alors de repérer les anomalies.

Une fois les anomalies corrigées, une relance de la macro va, si plus aucun doublon et plus aucune anomalies constatés, réafficher toutes les colonnes de l'onglet et terminer par le message : Le tableau est normal !.

Le fichier :

Bonjour.

Merci à vous 2 de vous être occupé de mon problème aussi rapidement.

@eric : toujours aussi prompt à répondre et complet !

@ThauThème : ton approche est très différente, en effet, beaucoup la trouverait passablement capilotractée (mais pour ma part, cela ne me pose pas de sushi : ma capillarité est réduite en cette période estivale ). Ceci dit, les commentaires sont très instructifs.

Ma première impression me ferait pencher du côté de ThauThème (effet "commentaires" ?)

Mais je vais sérieusement regarder et étudier les 2 propos' (afin de vraiment les comprendre

Ceci dit, une idée est venue pour insérer un bouton dans ce tableau, afin de "suspendre" et relancer la macro (puis le supprimer avant enregistrement)

Je vous tiens au jus dès que possible (d'ici à demain soir...)

PS @eriiic : la minuscule est "volontaire". Je traite ce cas un peu plus loin dans le code complet, avant d'enregistrer le fichier corrigé.

Ceci dit, rien de grave : aucune incidence sur le raccordement (ce n'est qu'une question de "propreté")

Salut à tous.

J'ai tardé à répondre : je m'en excuse.

Ceci étant, j'ai repris l'idée de base de ThauThème que j'ai adapté à mes besoins.

Il s'est avéré que je ne pouvais "créer" un nouvel onglet.... de plus, le fichier que j'avais donné était relativement raccourci (dans son nombre de colonnes)

Pour ceux / celle que cela pourrait interesser (et éventuellement s'il y a une optimisation à faire) voici le code :

Sub Position()

Dim TV As Variant, TL() As Variant
Dim DL As Integer, I As Integer, J As Integer, K As Integer
Dim ND As Integer '(Nombre de Doublons)
Dim NA As Integer '(Nombre d'Anomalies)
Dim TEST As Boolean

    Application.ScreenUpdating = False

    If Range("B8").Value = "" Then
        Columns("A:B").Select
        Selection.Delete Shift:=xlToLeft
    End If

    'Suppression du bouton si existant
    If ActiveSheet.Shapes.Count = 2 Then ' 2 car il y a déjà une image (shape)
        ActiveSheet.Shapes.Range(Array("Button_0")).Delete
    End If

    'Création d'un bouton
    ActiveSheet.Buttons.Add(545, 50, 245, 50).Select
    With Selection
        .Name = "Button_0"
        .OnAction = "Position"
        .Characters.Text = "Contrôle"
    End With
    With Selection.Characters(Start:=1, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Gras"
        .Size = 36
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleDouble
        .ColorIndex = 5
    End With

    Range("A1").Select

    Range("AO1:AZ1").EntireColumn.Clear
    DL = Cells(Application.Rows.Count, "B").End(xlUp).Row
    TV = Range("B11:E" & DL)

    K = 1
    For I = 1 To UBound(TV, 1)
        If TV(I, 1) <> "" Then
            ReDim Preserve TL(1 To 5, 1 To K)
            For J = 1 To 4
                TL(J, K) = TV(I, J)
            Next J
            TL(5, K) = I + 10
            K = K + 1
        End If
    Next I
    On Error Resume Next

    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Columns("A:A").Select
    Selection.ColumnWidth = 30
    Columns("B:B").Select
    Selection.ColumnWidth = 25
    Columns("A:B").Select
    With Selection
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    '**********************************
    'création d'un codage des 4 données
    '**********************************
    For I = 11 To DL
        If Cells(I, 4) <> "" Then
            Cells(I, 44).Value = CLng(Asc(UCase(Cells(I, 6).Value)) & Cells(I, 4).Value + Cells(I, 5).Value + Cells(I, 7).Value)
            Cells(I, 45).Value = I
        Else
            Cells(I, 44).Value = ""
        End If
    Next

    '*********************
    'repérage des doublons
    '*********************
    For I = 11 To DL
        For J = 11 To DL
            If J <> I And Cells(I, 4) <> "" And Cells(I, 44).Value = Cells(J, 44).Value Then
                Cells(I, 1).Value = "doublon avec la ligne " & J & " !"
                Cells(I, 1).Interior.ColorIndex = 6
                Cells(I, 41).Interior.ColorIndex = 6
                Cells(I, 41).Value = "NOK"
                Cells(I, 41).Font.Bold = True
                Cells(I, 41).Font.Color = -16776961
               ND = ND + 1
            End If
        Next J 'prochaine ligne de la boucle 2
    Next I 'prochaine ligne de la boucle 1

    '**********************
    'repérage des anomalies
    '**********************
    For I = 11 To DL
        If Cells(I + 1, 44) = Cells(I, 44) + 1 Or Cells(I, 44) = "" Or Cells(I + 1, 44) = "" Then GoTo suite
        If Cells(I + 1, 44) <> Cells(I, 44) + 1 And Cells(I + 2, 44) <> Cells(I + 1, 44) + 1 Then
            On Error Resume Next
            Cells(I + 1, 2).Value = "Incohérence position"
            Cells(I + 1, 41).Interior.ColorIndex = 6
            Cells(I + 1, 41).Value = "P-NOK"
            Cells(I + 1, 41).Font.Bold = True
            Cells(I + 1, 41).Font.Color = -16776961
            If Err <> 0 Then Err.Clear: GoTo suite 'va à l'étiquette "suite"
            Cells(I + 1, 2).Interior.ColorIndex = 44
            NA = NA + 1
        End If

'étiquette
suite:
    Next I
    TEST = False

'étiquette
fin:
    If TEST = False And ND = 1 And NA = 0 Then
        Range("AO1").Select
        MsgBox "Veuillez suprimer le doublon" _
        & Chr(10) & "Puis relancer la procédure (bouton " & Chr(34) & "Contrôle" & Chr(34) & ")", vbInformation
        Range("AQ1:AZ1").EntireColumn.Clear
        TEST = True 'définit la variable TEST
        Application.ScreenUpdating = True
        Exit Sub
    ElseIf TEST = False And ND = 0 And NA = 1 Then
        Range("AO1").Select
        MsgBox "Veuillez rectifier l' erreur de position" _
        & Chr(10) & "Puis relancer la procédure (bouton " & Chr(34) & "Contrôle" & Chr(34) & ")", vbInformation
        Range("AQ1:AZ1").EntireColumn.Clear
        TEST = True 'définit la variable TEST
        Application.ScreenUpdating = True
        Exit Sub
    ElseIf TEST = False And ND = 1 And NA = 1 Then
        Range("AO1").Select
        MsgBox "Veuillez supprimer le doublon et rectifier l'erreur de position" _
        & Chr(10) & "Puis relancer la procédure (bouton " & Chr(34) & "Contrôle" & Chr(34) & ")", vbInformation
        Range("AQ1:AZ1").EntireColumn.Clear
        TEST = True 'définit la variable TEST
        Application.ScreenUpdating = True
        Exit Sub
    ElseIf TEST = False And ND > 1 And NA = 0 Then
        Range("AO1").Select
        MsgBox "Veuillez suprimer les " & ND & " doublons" _
        & Chr(10) & "Puis relancer la procédure (bouton " & Chr(34) & "Contrôle" & Chr(34) & ")", vbInformation
        Range("AQ1:AZ1").EntireColumn.Clear
        TEST = True 'définit la variable TEST
        Application.ScreenUpdating = True
        Exit Sub
    ElseIf TEST = False And ND = 0 And NA > 1 Then 'condition : si TEST est [Faux] et ND est égal à 0 et NA est supérieure 0
        Range("AO1").Select
        MsgBox "Veuillez rectifier les " & NA & " erreurs de positions" _
        & Chr(10) & "Puis relancer la procédure (bouton " & Chr(34) & "Contrôle" & Chr(34) & ")", vbInformation
        Range("AQ1:AZ1").EntireColumn.Clear
        TEST = True 'définit la variable TEST
        Application.ScreenUpdating = True
        Exit Sub
    ElseIf TEST = False And ND > 1 And NA > 1 Then 'condition : si TEST est [Faux] et ND est supérieure à 0 et NA est supérieure 0
        Range("AO1").Select
        MsgBox "Veuillez supprimer les " & ND & " doublons et rectifier les " & NA & " erreurs de positions" _
        & Chr(10) & "Puis relancer la procédure (bouton " & Chr(34) & "Contrôle" & Chr(34) & ")", vbInformation
        Range("AQ1:AZ1").EntireColumn.Clear
        TEST = True 'définit la variable TEST
        Application.ScreenUpdating = True
        Exit Sub
    End If

    'à ce stade la macro s'arrête pour laisser à l'utilisateur la possibilité de rectifier les doublons avant le repérage des anomalies

    If NA = 0 And ND = 0 Then
        Columns("A:B").Select
        Selection.Delete Shift:=xlToLeft
        Range("A1").Select
        Range("AO1:AZ1").EntireColumn.Clear
        MsgBox "Contrôles terminés" _
        & Chr(10) & Chr(10) & "Prêt pour enregistrement", vbInformation
    End If 'fin de la condition

    Call Enregistrement
End Sub

Encore merci à ThauTème, qui m'a simplifié la tâche grace aux commentaires laissés sur le code (navré de les avoir retirés dans la version "finales"

Et merci aussi (encore) à eriiic

sujet "résolu" pour ma part

Bonjour,

perso je n'aime pas trop les On Error Resume Next qui ne semble pas trop maîtrisés ni contrôlés, et être là pour mettre la poussière sous le tapis

Il ne faut en mettre que là où une instruction est susceptible de faire une erreur connue, normale et attendue, et rétablir la gestion d'erreur juste après par on error goto 0

eric

Merci eriiic

Perso je n'ai jamais su gérer les erreurs (correctement)

Ben enlève-les et corrige s'il y a vraiment des erreurs. Ca ne sert à rien de cacher la misère et obtenir des résultats non fiables.

Il ne s'agit pas de faire du traitement d'erreur, tu les caches au lieu de les corriger... Si ça se trouve il n'y en a même pas.

Et si tu n'as pas le choix tu ne remets que pour LA ligne qui le justifie et tu remets le traitement d'erreur juste après.

Je te parles des resume next, pas des goto là-bas qui eux sont voulus.