[RESOLU] Non communs de 2 Dicos dans Msgbox

cathodique · 23 Décembre 2015

Bonsoir,

M'étant inspiré d'un code de Laetitia, je suis parvenu à extraire des données non communes de 2 dictionnaires.
Je voudrais affichées ces données non communes (une par ligne) si elles existent dans un Msgbox, sinon le message "BD à jour".

VB:

Option Explicit
Sub Message()
    Dim d1 As Object, d2 As Object
    Dim t1(), t2(), i As Long, j As Long, k As Variant
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")

    t1 = Feuil1.[A1].CurrentRegion.Value
    t2 = Feuil2.[A1].CurrentRegion.Value

    For Each k In t1
        d1(k) = d1(k)
    Next k
    For Each k In t2
        If Not d1.exists(k) Then d2(k) = d2(k)
    Next k
    Range("c2").Resize(d2.Count, 1) = Application.Transpose(d2.keys)

    MsgBox "Elément manquant"
End Sub

En vous remerciant

mapomme · 24 Décembre 2015

Re : NOn communs de 2 Dicos dans Msgbox

Bonjour cathodique,

Essayez:

Code:

    Range("c2:c" & rows.count).Clear
    If d2.Count > 0 Then
      Range("c2").Resize(d2.Count, 1) = Application.Transpose(d2.keys)
      MsgBox Join(d2.keys, vbLf)
    Else
      MsgBox "BD à jour"
    End If

cathodique · 24 Décembre 2015

Re : NOn communs de 2 Dicos dans Msgbox

Bonjour Mapomme,

Merci beaucoup. J'ai voulu rajouter un texte au message mais j'ai une erreur d'incompatibilité.
Je voudrais avoir cle &" :est manquante". Quelle est l'astuce pour obtenir ce résultat?

Avec mes remerciements.

laetitia90 · 24 Décembre 2015

Re : NOn communs de 2 Dicos dans Msgbox

bonjour cathodique, mapomme

Code:

  MsgBox Join(d2.keys, vbLf) & vbLf & "  manquante!!"

pour info vbLf renvoi a la ligne tu peus le manipuler pour mettre MANQUANTE au debut msgbox

cathodique · 24 Décembre 2015

Re : NOn communs de 2 Dicos dans Msgbox

Bonjour Laetitia90,

Tu me sauves encore une fois la vie. Merci, je me suis amusé à rajouter mon texte à l'intérieur des parenthèses de la fonction Join. Vraiment, cathodique soit que tu es trop bête ou tu te fais trop vieux.

Pourrais-tu s'il te plait me commenter le code (qui est fait ton code). Je suis parvenu à l'adapter sur mon fichier mais sans bien tout comprendre. Sur mon fichier, j'avais d'abord créé les dicos puis j'ai essayé de récupérer les données non communes.
Ton code est plus technique et subtile.

Tous mes remerciements.

Joyeuses fêtes de fin d'année à tous.

cathodique · 24 Décembre 2015

Re : [RESOLU]Non communs de 2 Dicos dans Msgbox

Re,
Laetitia, j'ai répondu hâtivement sans tester. Mais voici ce que j'obtiens

3 lignes D, E, manquants!!

Je voudrais obtenir 2 lignes comme ceci:
L'objet D est manquant
L'objet E est manquant

Merci beaucoup.

laetitia90 · 24 Décembre 2015

Re : [RESOLU]Non communs de 2 Dicos dans Msgbox

re

ben c'est assez simple

For Each k In t1
d1(k) = d1(k)
Next k

tu remplis les uniques de la feuille1

For Each k In t2
If Not d1.Exists(k) Then d2(k) = d2(k)
Next k

tu remplis les uniques de la feuille2

If Not d1.Exists(k) Then d2(k) = d2(k)

CETTE ligne qui est importante
tu verifie que item(k) de la feuille2 appartient pas au dico d1

IL Y A d'autres methode encore avec un seul dico encore plus simple & plus rapide

je l'ecris

cathodique · 24 Décembre 2015

Re : Non communs de 2 Dicos dans Msgbox

Merci pour la rapidité de ta réponse. Voici comment j'avais commencé mon code

VB:

Sub Message1()
    Dim d1 As Object, d2 As Object
    Dim t1(), t2(), i As Long, j As Long
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")

    t1 = Feuil1.[A1].CurrentRegion.Value
    t2 = Feuil2.[A1].CurrentRegion.Value

    For i = 1 To UBound(t1)
        d1(i) = d1(i)
    Next i
    
    For j = 1 To UBound(t2)
        d2(j) = d2(j)
    Next j
 End Sub

et toi tu utilises k comme variant, c'est ce qui fait la différence entre un connaisseur et un novice tel que moi.

laetitia90 · 24 Décembre 2015

Re : Non communs de 2 Dicos dans Msgbox

re tous

For Each k In t1

c est pareil que

For i = 1 To UBound(t1)

toujous une boucle?? le 2 plus simple a manipuler avec un tablo

autrement tu etais bien parti

Code:

Sub Message1()
    Dim d1 As Object, d2 As Object
    Dim t1(), t2(), i As Long, j As Long
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")

    t1 = Feuil1.[A1].CurrentRegion.Value
    t2 = Feuil2.[A1].CurrentRegion.Value

    For i = 1 To UBound(t1)
        d1(t1(i, 1)) = ""
    Next i
    
    For j = 1 To UBound(t2)
       If Not d1.Exists(t2(j, 1)) Then d2(t2(j, 1)) = ""
    
    Next j

   Feuil3.[c2].Resize(d2.Count, 1) = Application.Transpose(d2.keys)


 
 End Sub

PS JE ME RAPPEL PAS AVOIR ECRIT CE CODE AVEC K????

gosselien · 24 Décembre 2015

Re : Non communs de 2 Dicos dans Msgbox

laetitia90 à dit:
re tous

PS JE ME RAPPEL PAS AVOIR ECRIT CE CODE AVEC K????

après 1970 messages, c'est normal de ne pas se rappeler

cathodique · 24 Décembre 2015

Re : Non communs de 2 Dicos dans Msgbox

Re, Laetitia,

PS JE ME RAPPEL PAS AVOIR ECRIT CE CODE AVEC K????

Si, si, je t'assure. J'ai trouvé ce code avant-hier en effectuant des recherches. Dommage, que j'utilise Ccleaner sinon je t'aurais envoyé le lien de la discussion.

Je voulais dire que la subtilité résidait dans le fait d'avoir utilisé un même variant (k) pour les 2 tableaux (t1 et t2); au lieu de 2 long (ou entier) (i et j) pour chacun des tableaux.

Pour le message, tu n'aurai pas une idée? Pour avoir:
L'objet D est manquant
L'objet E est manquant

Merci.

laetitia90 · 24 Décembre 2015

Re : Non communs de 2 Dicos dans Msgbox

re tous

vu qu'on est sur une boucle For Each
fin de ton code

z en variant ou string

Code:

Range("c2:c" & Rows.Count).Clear
    If d2.Count > 0 Then
      Range("c2").Resize(d2.Count, 1) = Application.Transpose(d2.keys)
    'rajout
    For Each k In d2.keys
    z = z & "L'objet   " & k & "  " & d2.Item(k) & "  manquant !!" & vbLf
    Next k
      Else
      MsgBox "BD à jour"
    End If
    MsgBox z

comme cela tu sais boucle sur un dico en pourrait le mettre dans la boucle ci desous ou recuperer sur la feuille3 col c

If Not d1.Exists(k) Then
d2(k) = d2(k)
End If
Next k

BON NOEL A TOUS

cathodique · 24 Décembre 2015

[Parfaitement résolu] Non communs de 2 Dicos dans Msgbox

Re tout le monde,

C'est absolument parfait. Tous mes remerciements.

Joyeux Noël à toute la communauté.

mapomme · 24 Décembre 2015

Re : [Parfaitement résolu] Non communs de 2 Dicos dans Msgbox

Joyeux Noël à laetitia90, à cathodique, aux XLDiens,

Juste pour le FUN, un essai avec seulement trois variables.

VB:

Sub Message()
  Dim dico, tablo, clef
  
  Set dico = CreateObject("scripting.dictionary")
  tablo = Feuil2.[A1].CurrentRegion
  For Each clef In tablo: dico(clef) = vbNullString: Next clef
  
  tablo = Feuil1.[A1].CurrentRegion
  For Each clef In tablo
    If dico.exists(clef) Then dico.Remove clef
  Next clef
  For Each clef In dico: dico(clef) = clef & "  absent de BD1": Next clef
  
  Range("c2:c" & Rows.Count).Clear
  If dico.Count > 0 Then
    Range("c2").Resize(dico.Count, 1) = Application.Transpose(dico.keys)
    MsgBox Join(dico.items, vbLf)
  Else
    MsgBox "BD à jour"
  End If
End Sub

cathodique · 24 Décembre 2015

Re : [RESOLU] Non communs de 2 Dicos dans Msgbox

Trop gentil Mapomme,

J'avoue c'est un très beau cadeau de Noël. Merci beaucoup.

Comme je l'ai dit ICI , c'est vraiment grâce à vous tous que je suis parvenu à obtenir un résultat. Heureusement, que je n'aie pas de prof sinon il m'aurait mis un zéro point, et ce malgré le résultat final bon. C'est ce qu'on disait à mon époque.

J'ai le lien de ma discussion, si tu veux bien y apporter ta contribution qui ne sera pas de refus.

Joyeuses Fêtes de fin d'année à tous XLDiens.

Un grand merci à tous.

[RESOLU] Non communs de 2 Dicos dans Msgbox

cathodique

XLDnaute Barbatruc

Pièces jointes

mapomme

XLDnaute Barbatruc

Pièces jointes

cathodique

XLDnaute Barbatruc

laetitia90

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

Pièces jointes

laetitia90

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

laetitia90

XLDnaute Barbatruc

gosselien

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

laetitia90

XLDnaute Barbatruc

cathodique

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

Pièces jointes

cathodique

XLDnaute Barbatruc

Discussions similaires