VBA Probleme avec l'utilisation des dictionnaires
Bonjour,
Je débute en VBA et bloque sur cette macro.
J’ai 2 fichiers (pour simplifier j’ai tout mis dans un même fichier avec 2 feuilles F1 et F2)
F1 = feuille de travail où les équipes renseignent leurs actions
F2 = mise à jour des données (que je reçois tous les jours)
Je souhaite mettre à jour les statuts de F1 en fonction du numéro de dossier en se référant à F2
Exemple :
Si en F1 le contrat 8024 est en statut « en attente » et que sur F2 il est en « Vente non aboutie », je voudrais que la macro modifie le statut de F1 en « Vente non aboutie » mais seulement le statut, le reste des données ne doit pas changer.
J’ai bien une macro qui tourne et qui compare ligne à ligne mais le problème c’est que j’ai un fichier de 25000 lignes actuellement et il faut presque 10min pour faire tourner la macro.
Donc j’ai vu que les dictionnaires permettaient de réduire considérablement ces traitements, j’ai donc utilisé une macro trouvée sur un forum (désolé je ne sais plus où je l’ai trouvé…) que j’ai adaptée mais je bug sur la fin.
Ce que je cherche à faire :
J’ai 2 dictionnaires et compare les numéros de dossiers. Si j’ai une correspondance le numéro reste en noir sinon il devient bleu.
Ensuite je voudrais que les statuts F1 des numéros en noir soit écrasés par ceux de F2 et c’est là que ça bug, après le « then » (ligne : If Range(MonDico2(c)).Font.Color = vbBlack Then MonDico1(c).Offset(, -1) = MonDico2(c).Offset(, -1)
Et je ne comprends pas pourquoi ?
J’espère avoir été clair et m’excuse d’avance de mon code qui n’est certainement pas très conventionnel…
Merci pour votre aide précieuse !
'cherche les valeurs identique entre les deux feuilles et colore en blue si absent. Puis remplace la valeur de la colonne précédente si la cellule est noire
Sub ComparaisonColonne()
Dim F1, F2, MonDico1, MonDico2, c As Variant
Application.ScreenUpdating = False
Set MonDico1 = CreateObject("Scripting.Dictionary")
Set MonDico2 = CreateObject("Scripting.Dictionary")
Workbooks("Tableau UCD V2 SED2.xlsm").Activate
Sheets("F1").Activate
For Each c In Sheets("F1").Range("F:F").SpecialCells(xlCellTypeConstants, 23)
MonDico1(c.Value) = c.Address
Next
Workbooks("Tableau UCD V2 SED2.xlsm").Activate
Sheets("F2").Activate
For Each c In Sheets("F2").Range("F:F").SpecialCells(xlCellTypeConstants, 23)
MonDico2(c.Value) = c.Address
Next
Workbooks("Tableau UCD V2 SED2.xlsm").Activate
For Each c In MonDico2
Range(MonDico2(c)).Font.Color = IIf(MonDico1.Exists(c), vbBlack, vbBlue)
If Range(MonDico2(c)).Font.Color = vbBlack Then MonDico1(c).Offset(, -1) = MonDico2(c).Offset(, -1)
'End If
Next
Application.ScreenUpdating = True
End Sub
Bonjour,
Je verrai plutôt ça avec Find (les numéros de dossier étant censés être unique) :
Sub Test()
Dim F1 As Worksheet
Dim F2 As Worksheet
Dim PlageF1 As Range
Dim PlageF2 As Range
Dim CelF1 As Range
Dim CelF2 As Range
Set F1 = Worksheets("F1")
Set F2 = Worksheets("F2")
'défini les deux plages
With F1: Set PlageF1 = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)): End With
With F2: Set PlageF2 = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)): End With
'parcour la plage (colonne F) de la feuille F2
For Each CelF2 In PlageF2
'si la cellule à cette valeur...
If CelF2.Offset(, -1).Value = "Vente non aboutie" Then
'effectue la recherche du n° de dossier dans la colonne F de la feuille F1
Set CelF1 = PlageF1.Find(CelF2.Value, , xlValues, xlWhole)
'et si trouvé, modifie sa valeur
If Not CelF1 Is Nothing Then CelF1.Offset(, -1).Value = CelF2.Offset(, -1).Value
End If
Next CelF2
End Sub
Bonjour Theze,
Merci pour ton aide, effectivement le numéro de dossier est unique. Je pense ne pas avoir été assez précis, les statuts des dossiers peuvent être beaucoup plus variés (50 statuts possible en gros) et surtout j'ai déjà une macro qui fonctionne avec le find qui fonctionne très bien mais c'est trop lourd pour un fichier de 25000 lignes (ca bloque mon poste pendant 10min
Bonjour à tous,
Même raisonnement que Theze, je me passe de dictionnaire
Option Explicit
Sub test()
Dim a, b, i As Long, x
a = Sheets("F2").Range("a1").CurrentRegion.Value
With Sheets("F1").Range("a1").CurrentRegion
b = .Value
For i = 2 To UBound(b, 1)
If b(i, 5) = "En attente" Then
x = Application.Match(b(i, 6), Sheets("F2").Columns(6), 0)
If Not IsError(x) Then
If a(x, 5) = "Vente non aboutie" Then
b(i, 5) = a(x, 5)
End If
End If
End If
Next
.Value = b
End With
End Sub
klin89
Bonjour,
Avec deux dictionnaires, recherche d'une valeur dans l'autre, adapte à tes besoins sinon, voir les filtres élaborés :
Sub Test()
Dim Dico1 As Object
Dim Dico2 As Object
Dim Cle As Variant
Dim F1 As Worksheet
Dim F2 As Worksheet
Dim Plage As Range
Dim Cel As Range
Set F1 = Worksheets("F1")
Set F2 = Worksheets("F2")
With F1: Set Plage = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)): End With
Set Dico1 = CreateObject("Scripting.Dictionary")
For Each Cel In Plage: Dico1.Add Cel.Value, Cel.Offset(, -1).Value: Next Cel
With F2: Set Plage = .Range(.Cells(2, 6), .Cells(.Rows.Count, 6).End(xlUp)): End With
Set Dico2 = CreateObject("Scripting.Dictionary")
For Each Cel In Plage: Dico2.Add Cel.Value, Cel.Offset(, -1).Value: Next Cel
For Each Cle In Dico1.Keys
If Dico2.Exists(Cle) Then
Debug.Print "N° du contrat : " & Cle & " Etat en feuille 'F1' : >" & Dico1(Cle) & "< Etat en feuille 'F2' : >" & Dico2(Cle) & "<"
End If
Next Cle
End Sub
Bonsoir,
Merci à vous deux, je teste demain et vous tiens au courant
Bonjour,
J'ai testé vos codes :
- Klin89, le problème du find est le temps de traitement mais je garde ton code dans un coin, merci
- Theze, ton code fonctionne super, par contre je bloque sur la syntaxe pour le remplacement des valeurs (à la place du debug.print), j'ai essayé
If Dico2.Exists(Cle) Then Dico2(Cle).Value = Dico1(Cle).Value
mais ça ne marche pas j'ai une erreur "objet requis"...?
Merci encore de votre aide
bonjour
essayer ca
ceci est pour :
bad_seed a écrit :J’ai 2 dictionnaires et compare les numéros de dossiers. Si j’ai une correspondance le numéro reste en noir sinon il devient bleu.Ensuite je voudrais que les statuts F1 des numéros en noir soit écrasés par ceux de F2
Sub Comparaison()
Dim F1 As Worksheet, F2 As Worksheet, i As Integer, x As Integer
Dim Zone, tbl, nbF1 As Integer, nbF2 As Integer
Application.ScreenUpdating = False
Set F1 = Sheets("F1")
Set F2 = Sheets("F2")
nbF1 = F1.Range("F" & Rows.Count).End(xlUp).Row
nbF2 = F2.Range("F" & Rows.Count).End(xlUp).Row
ReDim tbl(0)
For i = 2 To nbF1
'If F1.Range("E" & i) = "En attente" Then
ReDim Preserve tbl(x)
tbl(x) = F1.Range("F" & i).Address(0, 0)
x = x + 1
'End If
Next
Zone = Join(tbl, ",")
With F2
For i = 2 To nbF2
'If .Range("E" & i) = "Vente non aboutie" Then
Set c = F1.Range(Zone).Find(.Range("F" & i), , , xlWhole)
If Not c Is Nothing Then
F1.Range("E" & c.Row) = .Range("E" & i) '= "Vente non aboutie"
.Range("F" & i).Font.Color = vbBlack 'vbBlue
Zone = Replace(Zone, "," & c.Address(0, 0), "")
Else
.Range("F" & i).Font.Color = vbBlue 'vbBlack
End If
'End If
Next
End With
Application.ScreenUpdating = True
End Sub
et pour :
bad_seed a écrit :Si en F1 le contrat 8024 est en statut « en attente » et que sur F2 il est en « Vente non aboutie », je voudrais que la macro modifie le statut de F1 en « Vente non aboutie » mais seulement le statut, le reste des données ne doit pas changer.
est mise en commentaire (couleur vert)
Re bad_seed,
Bonjour AMIR, Theze,
Puisque tu insistes 8)
Option Explicit
Sub test()
Dim a, i As Long, dico As Object
Set dico = CreateObject("Scripting.Dictionary")
a = Sheets("F2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dico(a(i, 6)) = a(i, 5)
Next
Application.ScreenUpdating = False
With Sheets("F1").Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
If dico.exists(a(i, 6)) Then
If a(i, 5) = "En attente" And dico(a(i, 6)) = "Vente non aboutie" Then
a(i, 5) = dico(a(i, 6))
.Cells(i, 5).Resize(, 2).Interior.ColorIndex = 37
End If
End If
Next
.Value = a
End With
Application.ScreenUpdating = True
End Sub
klin89
Re
Ou comme ceci :
Option Explicit
Sub test()
Dim a, i As Long, dico As Object, x As Range
Set dico = CreateObject("Scripting.Dictionary")
a = Sheets("F2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dico(a(i, 6)) = a(i, 5)
Next
Application.ScreenUpdating = False
With Sheets("F1").Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
If dico.exists(a(i, 6)) Then
If a(i, 5) = "En attente" And dico(a(i, 6)) = "Vente non aboutie" Then
a(i, 5) = dico(a(i, 6))
If x Is Nothing Then
Set x = .Range(.Cells(i, 5), .Cells(i, 6))
Else
Set x = Union(x, .Range(.Cells(i, 5), .Cells(i, 6)))
End If
End If
End If
Next
.Value = a
End With
If Not x Is Nothing Then x.Interior.ColorIndex = 37
Application.ScreenUpdating = True
End Sub
klin89
Bonjour Klin89, Amir et Theze,
Amir : ta solution fonctionne pour le fichier que j'ai mis en exemple, en revanche sur un fichier plus lourd ca plante (erreur 1004)
Klin89 : ton code fonctionne mais seulement pour les 2 statuts, je vais essayer de l'adapter pour tous les statuts (comme dans la solution de Theze).
et je reviendrais vers vous si je n'y arrive pas
bad_seed
bonjour
mais sur quelle ligne (ligne colorée en jaune)
Sur celle-ci
Set c = F1.Range(Zone).Find(.Range("F" & i), , , xlWhole)
bonjour
et que dit le message d erreur
Il dit ça : erreur d'exécution '1004' : La méthode 'Range' de l'objet '_Worksheet' a échoué
bien sur si la structure de ton fichier original est la meme avec le ficher exepmle :
nous traiterons lerreur aprés .
Maintenant :
1- Si en F1 le contrat 8024 est en statut « en attente » et que sur F2 il est en « Vente non aboutie », je voudrais que la macro modifie le statut de F1 en « Vente non aboutie » mais seulement le statut, le reste des données ne doit pas changer.
2-Ce que je cherche à faire :
J’ai 2 dictionnaires et compare les numéros de dossiers. Si j’ai une correspondance le numéro reste en noir sinon il devient bleu.
Ensuite je voudrais que les statuts F1 des numéros en noir soit écrasés par ceux de F2.
Je pense que se sont deux façon déférentes et je ne saie pas la quelle vous intéresse
Re et re, 8)
Alors, comme ça :
Option Explicit
Sub test()
Dim a, i As Long, dico As Object, x As Range, y As Range
Set dico = CreateObject("Scripting.Dictionary")
a = Sheets("F2").Range("a1").CurrentRegion.Value
For i = 2 To UBound(a, 1)
dico(a(i, 6)) = a(i, 5)
Next
Application.ScreenUpdating = False
With Sheets("F1").Range("a1").CurrentRegion
a = .Value
For i = 2 To UBound(a, 1)
If dico.exists(a(i, 6)) Then
If a(i, 5) = "En attente" And dico(a(i, 6)) = "Vente non aboutie" Then
a(i, 5) = dico(a(i, 6))
End If
If x Is Nothing Then
Set x = .Cells(i, 6)
Else
Set x = Union(x, .Cells(i, 6))
End If
Else
If y Is Nothing Then
Set y = .Cells(i, 6)
Else
Set y = Union(y, .Cells(i, 6))
End If
End If
Next
.Value = a
End With
Set dico = Nothing
If Not x Is Nothing Then x.Interior.ColorIndex = 44
If Not y Is Nothing Then y.Interior.ColorIndex = 37
Application.ScreenUpdating = True
End Sub
klin89
Amir, en fait je veux pouvoir comparer les statuts (quel qu’ils soient) de F1 et F2 et remplacer ceux de F1 par ceux de F2 s'ils sont différents avec comme "clé primaire" le numéro de dossier. Je ne sais pas si je suis plus clair maintenant ?
bonjour
L’erreur c était a cause d’une de mes bêtise
essayer ca :
Sub Comparaison()
Dim Start, Finish
Start = Timer ' Définit l'heure de début.
Dim F1 As Worksheet, F2 As Worksheet, c
Dim nbF1 As Long, nbF2 As Long, i As Long
Application.ScreenUpdating = False
Set F1 = Sheets("F1")
Set F2 = Sheets("F2")
nbF1 = F1.Range("F" & Rows.Count).End(xlUp).Row
nbF2 = F2.Range("F" & Rows.Count).End(xlUp).Row
With F2
For i = 2 To nbF2
'If .Range("E" & i) = "Vente non aboutie" Then
Set c = F1.Range("F2:F" & nbF1).Find(.Range("F" & i), , , xlWhole)
If Not c Is Nothing Then
F1.Range("E" & c.Row) = .Range("E" & i) '= "Vente non aboutie"
.Range("F" & i).Font.Color = vbBlack 'vbBlue
Else
.Range("F" & i).Font.Color = vbBlue 'vbBlack
End If
'End If
Next
End With
Application.ScreenUpdating = True
Finish = Timer ' Définit l'heure de fin.
MsgBox Finish - Start & " seconde(s)"
End Sub
oubien celui la je pense est plus rapide que le premier
Sub test2()
Dim Start, Finish
Start = Timer ' Définit l'heure de début.
Dim F1 As Worksheet, F2 As Worksheet
Dim nbF1 As Long, nbF2 As Long, Tbl() As Long, i As Long, x As Long
Application.ScreenUpdating = False
Set F1 = Sheets("F1")
Set F2 = Sheets("F2")
nbF1 = F1.Range("F" & Rows.Count).End(xlUp).Row
nbF2 = F2.Range("F" & Rows.Count).End(xlUp).Row
ReDim Tbl(nbF1 - 2)
With F2
For i = 2 To nbF2
'If .Range("E" & i) = "Vente non aboutie" Then
For x = 2 To nbF1
If Tbl(x - 2) <> 1 Then
If F1.Range("F" & x).Value = .Range("F" & i).Value Then
F1.Range("E" & x) = .Range("E" & i) '= "Vente non aboutie"
.Range("F" & i).Font.Color = vbBlack 'vbBlue
Tbl(x - 2) = 1
Else
.Range("F" & i).Font.Color = vbBlue 'vbBlack
End If
End If
'End If
Next
Next
End With
Application.ScreenUpdating = True
Finish = Timer ' Définit l'heure de fin.
MsgBox Finish - Start & " seconde(s)"
End Sub