XL 2013 Contrôle doublons et positions via VBA

famu

XLDnaute Occasionnel
Bonjour à tous,
Je tourne en rond pour créer une macro de contrôle.
Dans le fichier joint tout est expliqué (du moins je j'espère !)
Si quelqu'un pouvait m'aider...
D'avance un grand merci,
Famu
 

Pièces jointes

  • Test.xlsx
    12.3 KB · Affichages: 47

Dranreb

XLDnaute Barbatruc
Bonjour.
Utilisez un tableau et un Dictionary pour ça.
Pour chaque ligne retrouvez la clé dans le tableau d'après l'emplacement.
S'il elle n'existe pas dans le dico, créez la avec le n°de ligne pour Item.
Sinon vérifiez qu'elle porte déjà bien ce numéro de ligne.

Je viens d'essayer mais je m'aperçois qu'on perd la trace de l'emplacement déjà utilisé.
Plus compliqué que prévu mais je suis en passe d'y arriver.

VB:
Sub Test()
Dim PlgEmp As Range, TClés(), L&, C&, TEmp(), Clé, D As New Scripting.Dictionary, CelRés As Range
TClés = Feuil1.[A4:A18].Value
Set PlgEmp = Feuil1.[F3:J5]: TEmp = PlgEmp.Value
For L = 1 To UBound(TEmp, 1)
  For C = 1 To UBound(TEmp, 2)
    Clé = TClés(TEmp(L, C), 1)
    If D.Exists(Clé) Then
      Set CelRés = PlgEmp(L, C)
      If D(Clé) <> L Then
        Set CelRés = PlgEmp(L, C)
        L = D(Clé)
        C = 1: Do While TClés(TEmp(L, C), 1) <> Clé: C = C + 1: Loop
        Set CelRés = Union(PlgEmp(L, C), CelRés): Application.Goto CelRés
        MsgBox "Ligne différentes pour emplacements de """ & Clé & """." _
          & vbLf & "Cellules: " & CelRés.Address(0, 0), _
          vbInformation, "Test": Exit Sub: End If
    Else
      D(Clé) = L
      End If: Next C, L
End Sub
 
Dernière édition:

famu

XLDnaute Occasionnel
Bonjour Dranreb,
Vu le code que tu viens de faire...je suis impressionné ! J'était parti avec la fonction "find", variables etc...mais là, ce que tu fais est hors de ma portée !
En tout cas, je te remercie vraiment pour l'effort fourni.
En effet, c'est pas simple, mais j'ai confiance.
je ne peux qu'attendre...
 

Dranreb

XLDnaute Barbatruc
Autre version qui indique toutes les cellules incriminées :
VB:
Sub Test2()
Dim PlgEmp As Range, TClés(), L&, C&, TEmp(), Clé, D As New Scripting.Dictionary, CelRés As Range
TClés = Feuil1.[A4:A18].Value
Set PlgEmp = Feuil1.[F3:J5]: TEmp = PlgEmp.Value
For L = 1 To UBound(TEmp, 1)
  For C = 1 To UBound(TEmp, 2)
    Clé = TClés(TEmp(L, C), 1)
    If Not D.Exists(Clé) Then
      D(Clé) = L
    ElseIf D(Clé) <> L Then
      Set CelRés = PlgEmp(L, C): GoTo Zut: End If: Next C, L
Exit Sub
Zut: For L = 1 To UBound(TEmp, 1)
  For C = 1 To UBound(TEmp, 2)
     If TClés(TEmp(L, C), 1) = Clé Then Set CelRés = Union(PlgEmp(L, C), CelRés)
     Next C, L
Application.Goto CelRés
MsgBox "Lignes différentes pour emplacements de """ & Clé & """." _
  & vbLf & "Cellules: " & CelRés.Address(0, 0), vbInformation, "Test"
End Sub
Ne pas oublier de cocher la référence Microsoft Scripting Runtime
 

famu

XLDnaute Occasionnel
Bonjour PierreJean...content de vous voir. Ce n'est pas la première fois que vous me venez en aide !
Pour Dranreb : c'est presque bon mais si je mets tous les "A" en emplacement 1, par exemple, et que je relance la macro il garde en mémoire les anciennes infos.
Pour PierreJean : ben...çà a l'air de fonctionner nickel !
Je l'adapte à mon fichier et vous tiens informé mais pas avant début de semaine prochaine car c'est le W.E.
Grand merci à vous 2 car pour moi, c'est de la "haute voltige". BRAVO !
 

Dranreb

XLDnaute Barbatruc
Je n'ai pas tenu compte de la colonne B parce que ça me semblait n'être que des numéros d'ordres de 1 à 15
je me suis donc fié seulement à la leur position verticale.

Edit: Dans votre nouveau problème un emplacement peut être défini pour plusieurs lettres différentes de sorte que je ne comprend plus de quelle lettre un autre ou le même emplacement ne doit pas figurer dans une autre ligne…
 
Dernière édition:

famu

XLDnaute Occasionnel
Bonjour PierreJean,
J'ai essayé d'adapter votre code à mon fichier d'origine mais ça ne fonctionne pas.
Je pensais y arriver comme un grand...
J'ai créé la Feuil2 qui est une copie de mon fichier et un bouton Macro dont la Macro a été modifiée...mais sans résultat.
Pas toujours facile VBA.
D'avance merci
 

Pièces jointes

  • Test (27) (1).xlsm
    44 KB · Affichages: 38

famu

XLDnaute Occasionnel
Bonjour,
Je reviens avec le fichier dont PierreJean et Dranreb m'avait bien aidé.
Je voudrais avoir une autre possibilité de contrôle (Feuil "Ctrl code unique ts emplacmts"). Tout y est expliqué.
En fait, je ne voudrais plus, pour cette macro, considérer les Lignes. Ce qui devrait être plus simple (?)
D'avance merci pour votre aide.
 

Pièces jointes

  • Copie de Test (27) (1) (1).xlsm
    49.9 KB · Affichages: 48

Statistiques des forums

Discussions
312 799
Messages
2 092 226
Membres
105 297
dernier inscrit
Cadnov