Nettoyage liste de diffusion sur excel [résolu]

[Eugene1979]

Bonjour,

Je sollicite votre précieuse aide pour adapter cet outil, afin qu'il puisse tourner sur les versions récentes d'Excel (2007 et plus...) et ainsi supporter plus de 65536 lignes, une limite à Excel 2003.

Je l'ai convertir en .xlsm, il a pu supporté 1.048.576 ligne mais au moment de l'exécution de l'opération il affiche une erreur : "Erreur d'exécution '13' : Incompatibilité de type" dès que le nombre de ligne dans la colonne A ou B dépasse 65536

Principe :

Dans la colonne A on met une liste de nom qu'on veut nettoyer, dans la colonne B on met une autre liste de nom qui ne doit plus se trouver dans la colonne de résultat C, le tout après avoir appuyer sur le bouton.

c'est-à-dire C = A - B

Cordialement

 

[cp4]

Bonjour, à tester

Option Explicit
Public Sub test()
Dim a, b, c
Dim monDico1 As Object, monDico2 As Object
   
    Application.ScreenUpdating = False
    Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row).Delete
    a = Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row) '* Modif cette ligne
    Set monDico1 = CreateObject("Scripting.Dictionary")
    For Each c In a
        monDico1(c) = ""
    Next c
    b = Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row) '* Modif cette ligne
    Set monDico2 = CreateObject("Scripting.Dictionary")
    For Each c In b
        If Not monDico1.exists(c) Then monDico2(c) = ""
    Next c
    [C2].Resize(monDico2.Count, 1) = Application.Transpose(monDico2.keys)
   
    Set monDico1 = Nothing: Set monDico2 = Nothing
End Sub

 

[Bebere]

bonjour

Option Explicit
Public Sub test()
Dim a, b 'outils,références cocher microsoftscriptingruntime,le code sera beaucoup plus rapide
Dim monDico1 As New Dictionary, monDico2 As New Dictionary
Dim c

    Application.ScreenUpdating = False
    Range("C2:C" & Range("C" & Rows.Count).End(xlUp).Row).Delete
    a = Range("B2:B" & [B1048576].End(xlUp).Row)
'    Set monDico1 = CreateObject("Scripting.Dictionary")
    For Each c In a
        monDico1(c) = ""
    Next c
    b = Range("A2:A" & [A1048576].End(xlUp).Row)
'    Set monDico2 = CreateObject("Scripting.Dictionary")
    For Each c In b
        If Not monDico1.exists(c) Then monDico2(c) = ""
    Next c
    [C2].Resize(monDico2.Count, 1) = Application.Transpose(monDico2.keys)
   
    Set monDico1 = Nothing: Set monDico2 = Nothing

End Sub

Sub AjoutRéfScripting() 'si microsoftscriptingruntime absent
    ActiveWorkbook.VBProject.References.AddFromFile "C:\WINDOWS\SysWOW64\MSCOMCTL.OCX"
End Sub

 

[Eugene1979]

Bonjour,

merci pour vos réponses

malheureusement toujours erreurs

 

[cp4]

Je n'ai pas eu d'erreur avec le fichier joint.

 

[Efgé]

Bonjour à tous

Je pense que le Transpose pose problème...
En passant par un tableau intermédiaire peut_être

Public Sub test()
Dim i&
Dim monDico1 As Object, monDico2 As Object
Dim a As Variant, b As Variant, T As Variant, k As Variant
Dim Rng As Range

Set monDico1 = CreateObject("Scripting.Dictionary")
Set monDico2 = CreateObject("Scripting.Dictionary")

With Sheets("Feuil1")
    Set Rng = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))
    a = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
    b = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

For i = LBound(a, 1) To UBound(a, 1)
    monDico1(a(i, 1)) = ""
Next i
For i = LBound(b, 1) To UBound(b, 1)
    If Not monDico1.exists(b(i, 1)) Then monDico2(b(i, 1)) = ""
Next i

ReDim T(1 To monDico2.Count, 1 To 1)
i = 0
For Each k In monDico2.keys
    i = i + 1
    T(i, 1) = k
Next k

Application.ScreenUpdating = False
    With Rng
        .ClearContents
        .Resize(monDico2.Count, 1) = T
    End With
Application.ScreenUpdating = True
Set monDico1 = Nothing: Set monDico2 = Nothing

End Sub

Cordialement

Edit

Je pense que sur un grand nombre dee lignes, cette version est plus adaptée

 

[Eugene1979]

Bonjour Efgé

Vous avez raison, le votre semble bon.

exécuté depuis l'éditeur il a bien fonctionné avec un essai de 100000 lignes.

Je suis un débutant, je n'arrive pas à re-associer le bouton.

Si vous pouvez le faire et envoyer le fichier tout prêt ici.

Salutations distinguées

 

[Efgé]

Re

La version définitive (je suis surpris que vous ne sachiez pas associer un code a un bouton alors que c'est déjà fait dans l'exemple.... )

Une indication. Dans la syntaxe .cells(2,3) il faut lire Cells(Ligne, colonne)

Cordialement

 

[Eugene1979]

Problème résolu merci à vous tous.

 

[cp4]

Salut Efgé,

Tu as raison en ce qui concerne le transpose. il est expliqué sur pas mal de discussions que le transpose posait problème dès que le nombre de lignes dépasse 65536.

Or le code du post#2 mis dans le fichier du post#5 ne plante pas. Bien que le nombre de lignes dépasse la limite ci-dessus. Je n'arrive pas à me l'expliquer. Auriez-vous une explication? Merci.

Bonne soirée.

 

[Efgé]

Bonjour à tous, Bonjour cp4

Le mystère du transpose dépend de la version d'Excel utilisée.
Non seulement de la version (2007, 2010 etc ...) mais aussi de la version de la dernière mise à jour utilisée.
Le problème est criant lors du passage d'un classeur 2003 à 2007.
Dans le post 2 tu as d’ailleurs bien raison en utilisant Rows.Count.

Donc, pour ma part, je n'utilise plus de transpose. Je passe toujours par un tableau relais.
Bien sûr on perd du temps, mais entre 0,01 seconde supplémentaire et un plantage, le choix est vite fait 😀

Cordialement

Edit:
Je profite de ma réponse pour modifier le code en prenant en compte un résultat "vide" et en anticipant la présence de date :

Private Sub cmdMAJliste_Click()
Dim i&
Dim monDico1 As Object, monDico2 As Object
Dim a As Variant, b As Variant, T As Variant, k As Variant
Dim Rng As Range

Set monDico1 = CreateObject("Scripting.Dictionary")
Set monDico2 = CreateObject("Scripting.Dictionary")

With Sheets("Feuil1")
    Set Rng = .Range(.Cells(1, 3), .Cells(.Rows.Count, 3).End(xlUp))
    a = .Range(.Cells(1, 2), .Cells(.Rows.Count, 2).End(xlUp))
    b = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

For i = LBound(a, 1) To UBound(a, 1)
    monDico1(a(i, 1)) = ""
Next i
For i = LBound(b, 1) To UBound(b, 1)
    If Not monDico1.exists(b(i, 1)) Then monDico2(b(i, 1)) = ""
Next i

Application.ScreenUpdating = False
    Rng.ClearContents
    If monDico2.Count > 0 Then
        ReDim T(1 To monDico2.Count, 1 To 1)
        i = 0
        For Each k In monDico2.keys
            i = i + 1
            T(i, 1) = k
        Next k
        Rng.Resize(monDico2.Count, 1).FormulaLocal = T
    End If
Application.ScreenUpdating = True

Set monDico1 = Nothing: Set monDico2 = Nothing
End Sub

 

[cp4]

Bonjour Efgé🙂,

Merci beaucoup pour tes explications.
Je vais mettre ton code en lieu sûr et assimiler ton astuce.

Bon dimanche.