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