Quelques problemes sur une macro avec des dictionnaires
Bonjour !
Je doit faire une macro excel qui compare des valeurs par 2 de 2 feuilles differents pour mettre a jour des données ou en ajouter. J'ai pensé a associer les paires de données pour en avoir qu'une seul, les mettre dans des dictionnaires (1 par feille) pour ensuite comparer les valeurs dans ces dictionnaires.
Cependant je rencontre qq problemes. merci d'avance a ceux qui prendront le temps de check cette cata ahah
Sub Mettre a jour dossier()
Dim feuilleForm As Worksheet
Dim feuilleBD As Worksheet
Dim Critere1 As Variant
Dim Critere2 As Variant
Dim plageRecherche As Range
Dim cellule As Range
Dim ligneTrouvee As Range
Dim derniereligne As Long
Dim derniereligneForm As Long
Dim dictionnaire As Object
Dim dictionnaire2 As Object
Dim feuille As Worksheet
Dim i As Long
Dim y As Long
Dim CellD As Variant
Dim CellG As Variant
Dim o As Variant
Dim Num1 As Variant
Dim Num2 As Variant
Dim Correspondance As Variant
Set feuilleForm = ThisWorkbook.Sheets("Form")
Set feuilleBD = ThisWorkbook.Sheets("BD")
Set dictionnaire = CreateObject("Scripting.Dictionary")
Set dictionnaire2 = CreateObject("Scripting.Dictionary")
'Récupere tout les paires de valeur de la feuille BD
derniereligne = feuilleBD.Cells(feuilleBD.Rows.Count, "D").End(xlUp).Row
For i = 2 To derniereligne
CellD = feuilleBD.Cells(i, "D").Value
CellG = feuilleBD.Cells(i, "G").Value
dictionnaire.Add CellD & CellG
Next i
'Récupere tout les paires de valeur de la feuille BD
derniereligneForm = feuilleForm.Cells(feuilleBD.Rows.Count, "D").End(xlUp).Row
For y = 9 To derniereligne
Critere1 = feuilleForm.Cells(y, "D").Value
Critere2 = feuilleForm.Cells(y, "C").Value
dictionnaire.Add Critere1 & Critere2
Next i
'Chercher une correspondane pour chaque valeur du dictionnaire 1 dans le dictionnaire 2.
'Si correspondance trouvé ---> fonction IF
'Si aucune correspondance trouvée ---> fonction "ajouter une ligne"
For Each Value1 In dictionnaire.keys
o = 2
Correspondance = InStrRev(dictionnaire2, Value1)
If Correspondance = 0 Then
derniereligne = Cells(Rows.Count, 1).End(xlUp).Row
Rows(derniereligne + 1).Insert Shift:=xlDown
Else
For Each Value2 In dictinnaire2.keys
'COMMENT DIFFENCIER LES VALEURS PRESENTES DANS LES 2 DICTIONNAIRES ? Value1 et Value2
If Value1 = Value2 Then
Set ligneTrouvee = cellule.EntireRow
If feuilleBD.Range("H" & o).Value <> ligneTrouvee.Cells(11) Then
ligneTrouvee.Cells(11).Value = feuilleBD.Range("H" & o).Value
ligneTrouvee.Cells(11).Interior.Color = RGB(255, 200, 255)
End If
End If
Next Value2
'Augmenter la valuer de o pour que la ligne ou les info sont modifiées change
o = o + 1
Next Value1
End SubIl y a plus de Dim que ce qui est utilisé car les actions a effectuer sont plus longue mais elles marchent indépendament donc je les ai enlevé pour ecourter la lecture.
Louma
bonjour,
dans quelle feuille dois-tu ajouter ou modifier les données ? feuilleBD ou feuilleform ? le plus simple est de mettre un fichier exemple représentatif, (anonymisé si nécessaire)
Bonjour,
En plus du fichier veuillez indiquer également le nombre de ligne réel des feuilles...
A+
Oui ! voici le fichier et la macro que j'essaye de faire marche mtn (spoil ca marche quand meme pas, meme si j'ai l'impression d'approcher du but)
Je doit mettre a jour les données dans la feuille Form a partir de celles présentes dans la feuille BD
Sub Mettreajourdossier()
Dim feuilleForm As Worksheet
Dim feuilleBD As Worksheet
Dim Critere1 As Variant
Dim Critere2 As Variant
Dim plageRecherche As Range
Dim cellule As Range
Dim ligneTrouvee As Variant
Dim derniereligne As Long
Dim derniereligneBD As Long
Dim derniereligneForm As Long
Dim dictionnaire1 As Object
Dim dictionnaire2 As Object
Dim feuille As Worksheet
Dim i As Long
Dim y As Long
Dim CellD As Variant
Dim CellG As Variant
Dim o As Variant
Dim Num1 As Variant
Dim Num2 As Variant
Dim Correspondance As Variant
Dim key As Variant
Set feuilleForm = ThisWorkbook.Sheets("Form")
Set feuilleBD = ThisWorkbook.Sheets("BD")
Set dictionnaire1 = CreateObject("Scripting.Dictionary")
Set dictionnaire2 = CreateObject("Scripting.Dictionary")
'Récupere tout les paires de valeur de la feuille BD
derniereligneBD = feuilleBD.Cells(feuilleBD.Rows.Count, "D").End(xlUp).Row
For i = 2 To derniereligne
CellD = feuilleBD.Cells(i, "D").Value
CellG = feuilleBD.Cells(i, "G").Value
dictionnaire1.Add CellD & CellG
Next i
'Récupere tout les paires de valeur de la feuille BD
derniereligneForm = feuilleForm.Cells(feuilleForm.Rows.Count, "D").End(xlUp).Row
For y = 9 To derniereligne
Critere1 = feuilleForm.Cells(y, "D").Value
Critere2 = feuilleForm.Cells(y, "C").Value
dictionnaire2.Add Critere1 & Critere2
Next y
'Modifier o pour qu'il corresponde a la ligne trouvé de key dic2 n'existant pas dans key dic1
o = 2
p = 2
ligneTrouvee = 9
'Cherche une correspondane pour chaque key dictionnaire 1 dans key dictionnaire 2 pour mettre a jour le solde et collorer si il a été modifié
For Each key In dictionnaire1.key
If dictionnaire2.Exists(key) Then
If dictionnaire1(key) = dictionnaire2(key) Then
If feuilleBD.Range("H" & p).Value <> ligneTrouvee.Cells(11) Then
ligneTrouvee.Cells(11).Value = feuilleBD.Range("H" & p).Value
ligneTrouvee.Cells(11).Interior.Color = RGB(255, 200, 255)
ligneTrouvee = ligneTrouvee + 1
p = p + 1
End If
End If
End If
Next key
'Cherche les valeur de key dic2 qui n'existe pas dans key dic 1 pour ajouter la ligne correspondante
For Each key In dictionnaire2.Keys
If Not dictionnaire1.Exists(key) Then
derniereligne = Cells(Rows.Count, 1).End(xlUp).Row
Rows(derniereligne + 1).Insert Shift:=xlDown
'Trouve un moyen pour que o ne monte pas d'une ligne pas une ligne mais prenne la ligne ou key dic2 n'as pas été trouvé dans key dic2
Cells(derniereligne + 1, 2).Value = feuilleBD.Range("B" & o).Value
Cells(derniereligne + 1, 3).Value = feuilleBD.Range("G" & o).Value
Cells(derniereligne + 1, 4).Value = feuilleBD.Range("D" & o).Value
Cells(derniereligne + 1, 5).Value = feuilleBD.Range("E" & o)
If Range("D" & o).Value = "" Then
Cells(derniereligne + 1, 6).Value = "?"
ElseIf Range("D" & o).Value >= 600000 Then
Cells(derniereligne + 1, 6).Value = "R"
ElseIf Range("D" & o).Value < 600000 Then
Cells(derniereligne + 1, 6).Value = "B"
End If
Cells(derniereligne + 1, 7).Value = feuilleBD.Range("F" & o)
'La ligne collone 8 utilise une plage non présente dans le fichier test. La rajouter a la fin (simple
Cells(derniereligne + 1, 9).Value = feuilleBD.Range("H" & o).Value
Cells(derniereligne + 1, 10).Value = feuilleBD.Range("C" & o).Value
Cells(derniereligne + 1, 11).Value = feuilleBD.Range("H" & o).Value
Cells(derniereligne + 1, 12).Value = "?"
o = o + 1
End If
Next key
End SubBonjour Loumatrix,
A tester :
Sub MettreAJourDossier()
'... Vos déclarations de variables ici ...
' Récupère toutes les paires de valeur de la feuille BD
' ...
' Récupère toutes les paires de valeur de la feuille Form
' ...
' Met à jour o, p et ligneTrouvee pour correspondre à la clé trouvée de dic2 n'existant pas dans dic1
o = 2
p = 2
ligneTrouvee = 9
' Cherche une correspondance pour chaque clé du dictionnaire1 dans le dictionnaire2 pour mettre à jour le solde et colorer si elle a été modifiée
For Each key In dictionnaire1.Keys
If dictionnaire2.Exists(key) Then
If dictionnaire1(key) = dictionnaire2(key) Then
If feuilleBD.Cells(p, "H").Value <> feuilleForm.Cells(ligneTrouvee, 11).Value Then ' Correction ici
feuilleForm.Cells(ligneTrouvee, 11).Value = feuilleBD.Cells(p, "H").Value
feuilleForm.Cells(ligneTrouvee, 11).Interior.Color = RGB(255, 200, 255)
End If
ligneTrouvee = ligneTrouvee + 1
p = p + 1
End If
End If
Next key
' Cherche les clés de dic2 qui n'existent pas dans dic1 pour ajouter la ligne correspondante
For Each key In dictionnaire2.Keys
If Not dictionnaire1.Exists(key) Then
derniereligne = feuilleBD.Cells(Rows.Count, 1).End(xlUp).Row
feuilleBD.Rows(derniereligne + 1).Insert Shift:=xlDown
' ... Votre code pour remplir les cellules ici ...
o = o + 1
End If
Next key
End Submerci, j'ai testé, mais malheureusement ca ne fonctionne toujours pas.
Apres avoir testé de mettre des msg box apres la création des dictionnaires, ceux la sont en realité vide, donc ils ne prennent pas en compte les valeur :(
bonjour,
le but est-il bien d'avoir dans la feuille form toutes les lignes de la feuille BD ? j'ai un doute.
voici ce que j'ai compris du code.
recherche dans la BD toutes les lignes de form et le mettre à jour la colonne H de form avec la valeur de la colonne H de feuille si valeur différente ?
puis on parcourt BD et on ajoute toutes les lignes qui se ne se trouve pas dans form.
pour moi cela revient à prendre BD tel quel en modifiant l'ordre des colonnes.
Le but est d'y ajouter les lignes qui n'y sont pas présente, et de mettre a jour celles qui y sont deja en changeant le "Montant"
re-bonjour,
donc
pour moi cela revient à prendre toutes les infos de BD telles quelles en modifiant l'ordre des colonnes.
Rebonjour
Le soucis est de verifier si la ligne existant deja, pour collorer le nouveau montant afin de voir qu'il a été modifié.
apres j'me casse probablement la tete pour pas grand chose :x
Re bonjour,
Je pense que votre code actuel ne mette pas correctement à jour le "Montant" et n'ajoute pas correctement les nouvelles lignes à la feuille "Form" à voir.
Un code que vous pourrez tester :
Sub Mettreajourdossier()
Dim feuilleForm As Worksheet
Dim feuilleBD As Worksheet
Dim Critere1 As Variant
Dim Critere2 As Variant
Dim derniereligneBD As Long
Dim derniereligneForm As Long
Dim dictionnaire1 As Object
Dim i As Long
Dim y As Long
Dim CellD As Variant
Dim CellG As Variant
Dim o As Variant
Dim key As Variant
Set feuilleForm = ThisWorkbook.Sheets("Form")
Set feuilleBD = ThisWorkbook.Sheets("BD")
Set dictionnaire1 = CreateObject("Scripting.Dictionary")
'Récupere toutes les paires de valeur de la feuille BD
derniereligneBD = feuilleBD.Cells(feuilleBD.Rows.Count, "D").End(xlUp).Row
For i = 2 To derniereligneBD
CellD = feuilleBD.Cells(i, "D").Value
CellG = feuilleBD.Cells(i, "G").Value
dictionnaire1.Add CellD & CellG, i
Next i
'Cherche correspondance pour chaque paire dans la feuille Form
derniereligneForm = feuilleForm.Cells(feuilleForm.Rows.Count, "D").End(xlUp).Row
For y = 9 To derniereligneForm
Critere1 = feuilleForm.Cells(y, "D").Value
Critere2 = feuilleForm.Cells(y, "C").Value
key = Critere1 & Critere2
If dictionnaire1.Exists(key) Then
'Si correspondance trouvée, mettre à jour le montant
feuilleForm.Cells(y, "H").Value = feuilleBD.Cells(dictionnaire1(key), "H").Value
feuilleForm.Cells(y, "H").Interior.Color = RGB(255, 200, 255)
dictionnaire1.Remove key
End If
Next y
'Ajoute les lignes restantes de la feuille BD à la feuille Form
For Each key In dictionnaire1.Keys
o = dictionnaire1(key)
derniereligneForm = feuilleForm.Cells(feuilleForm.Rows.Count, "D").End(xlUp).Row + 1
feuilleForm.Range("D" & derniereligneForm & ":G" & derniereligneForm).Value = _
feuilleBD.Range("D" & o & ":G" & o).Value
Next key
End Submerci bcp pour ces corrections, j'y ai jété un coup d'oeil mais j'ai l'impression que comme H2S04 me l'as fait comprendre je me suis embourbé dans un code bcp trop compliqué pour quelque chose de simple.
J'ai repensé un moyen plus simple d'atteindre mon objctif et je reviens vers vous quand il fonctionne
bonjour,
voici une proposition de modification de ton code
Sub Mettreajourdossier()
Dim feuilleForm As Worksheet
Dim feuilleBD As Worksheet
Dim Critere1 As Variant
Dim Critere2 As Variant
Dim plageRecherche As Range
Dim cellule As Range
Dim ligneTrouvee As Range
Dim derniereligne As Long
Dim derniereligneForm As Long
Dim dictionnaire As Object
Dim dictionnaire2 As Object
Dim feuille As Worksheet
Dim i As Long
Dim y As Long
Dim CellD As Variant
Dim CellG As Variant
Dim o As Variant
Dim Num1 As Variant
Dim Num2 As Variant
Dim Correspondance As Variant
Set feuilleForm = ThisWorkbook.Sheets("Form")
Set feuilleBD = ThisWorkbook.Sheets("BD")
Set dictionnaire = CreateObject("Scripting.Dictionary")
derniereligneForm = feuilleForm.Cells(Rows.Count, 1).End(xlUp).Row
derniereligne = feuilleBD.Cells(Rows.Count, 1).End(xlUp).Row
Set dictionnaire = CreateObject("Scripting.Dictionary")
' creer un dictionnaire avec les lignes présentes dans form
For i = 9 To derniereligneForm
CellD = feuilleForm.Cells(i, "D").Value
CellC = feuilleForm.Cells(i, "C").Value
dictionnaire.Add CellD & CellC, i 'attention pas de gestion de l'erreur en cas de doublon
Next i
For i = 2 To derniereligne 'parcourt toute la BD
Critere1 = feuilleBD.Cells(i, "D")
Critere2 = feuilleBD.Cells(i, "G")
If dictionnaire.exists(Critere1 & Critere2) Then 'ligne de BD présente dans form
o = dictionnaire(Critere1 & Critere2) 'oui, o est le numéro de ligne dans Form
If feuilleForm.Cells(o, 11) <> feuilleBD.Range("H" & i) Then 'montant différent
feuilleForm.Cells(o, 11) = feuilleBD.Range("H" & i) 'on modifie la colonne K de la form avec l'info de la BD en colonne H
feuilleForm.Cells(o, 11).Interior.Color = RGB(255, 200, 255)
Else 'même montant
feuilleForm.Cells(o, 11).Interior.Color = RGB(255, 255, 255)
End If
Else 'ligne de BD absente de form on ajoute les données dans form
derniereligneForm = derniereligneForm + 1
feuilleForm.Rows(derniereligneForm).Insert
feuilleForm(derniereligneForm - 1, 1).Copy feuilleForm.Cells(derniereligneForm, 1)
feuilleForm.Cells(derniereligneForm, 2).Value = feuilleBD.Range("B" & i).Value
feuilleForm.Cells(derniereligneForm, 3).Value = feuilleBD.Range("G" & i).Value
feuilleForm.Cells(derniereligneForm, 4).Value = feuilleBD.Range("D" & i).Value
feuilleForm.Cells(derniereligneForm, 5).Value = feuilleBD.Range("E" & i)
If feuilleBD.Range("D" & i).Value = "" Then
feuilleForm.Cells(derniereligneForm, 6).Value = "?"
ElseIf feuilleBD.Range("D" & i).Value >= 600000 Then
feuilleForm.Cells(derniereligneForm, 6).Value = "R"
ElseIf feuilleBD.Range("D" & i).Value < 600000 Then
feuilleForm.Cells(derniereligneForm, 6).Value = "B"
End If
feuilleForm.Cells(derniereligneForm, 7).Value = feuilleBD.Range("F" & i)
feuilleForm.Cells(derniereligneForm, 9).Value = feuilleBD.Range("H" & i).Value
feuilleForm.Cells(derniereligneForm, 10).Value = feuilleBD.Range("C" & i).Value
feuilleForm.Cells(derniereligneForm, 11).Value = feuilleBD.Range("H" & i).Value
feuilleForm.Cells(o, 11).Interior.Color = RGB(255, 255, 255)
feuilleForm.Cells(derniereligneForm, 12).Value = "?"
End If
Next i
End SubA priori ce que vous m'avez envoyé marche, merci beaucoup et bravo. Je vais etudier ca pour comprendre ou j'ai fait mal les choses
A priori bcp de problemes ont été reglés mais il en subsiste 2.
1 : le calcul de la collone 6 avec les condition ne fonctionne pas (je pense pouvoir m'en charger tout seul)
2 : lorsque l'on utilise 2 fois la macro, elle recréé les nouvelles lignes comme si elles ne les reconnaissaient pas.
ex: depart : mon fichier a 2 lignes. J'en rajoute une dans la BD et lance la macro ---> la macro créé une troisieme ligne
2eme utilisation : la macro recréé la 3eme ligne a nouveau, comme si elle ne l'avait pas ajouter dans son dictionnaire
C'est tout bon ! j'ai corrigé les 2 problemes.
Encore merci a tous :D