avec l’objet “Dictionary”.

[moteurV12]

Bonsoir à Toutes et Tous

Je souhaiterai remplacer le code suivant qui compare 2 colonnes lentement


Set rngA = Range(Cells(1, "BM"), Cells(Rows.Count, "BM").End(xlUp))
Set rngB = Range(Cells(1, "R"), Cells(Rows.Count, "R").End(xlUp))


For Each cell In rngA
titi = Range("AJ2").Value ' titi est un compteur
If Not IsError(Application.Match(cell.Value, rngB, 0)) Then
Cells(titi + 1, "F").Value = Cells(cell.Row, "BM").Value
End If
Next

Par un objet Dictionary plus rapide

 

[pierrejean]

Re : avec l’objet “Dictionary”.

Bonjour moteurv12

Teste ceci (après adaptation)

Sub uniques()
t1 = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
t2 = Range("B1:B" & Range("B" & Rows.Count).End(xlUp).Row)
Set dico = CreateObject("Scripting.dictionary")
For n = LBound(t1, 1) To UBound(t1, 1)
x = t1(n, 1)
dico(x) = x
Next
For n = LBound(t2, 1) To UBound(t2, 1)
x = t2(n, 1)
dico(x) = x
Next
Range("F1").Resize(dico.Count) = Application.Transpose(dico.keys)
End Sub

 

[moteurV12]

Re : avec l’objet “Dictionary”.

Merci pierrejean j'y vais de ce pas et merci
A de suite pour le suivi

 

[moteurV12]

Re : avec l’objet “Dictionary”.

j'ai adapté comme suit

t1 = Range("BM1:BM" & Range("BM" & Rows.Count).End(xlUp).Row)
t2 = Range("R1:R" & Range("R" & Rows.Count).End(xlUp).Row)
Set Dico = CreateObject("Scripting.dictionary")
For n = LBound(t1, 1) To UBound(t1, 1)
X = t1(n, 1)
Dico(X) = X
Next
For n = LBound(t2, 1) To UBound(t2, 1)
X = t2(n, 1)
Dico(X) = X
Next
Range("F1").Resize(Dico.Count) = Application.Transpose(Dico.Keys)


et au lieu d'avoir le commun entre les 2 colonnes j'obtiens toutes les valeurs contenues en "BM"

 

[BOISGONTIER]

Re : avec l’objet “Dictionary”.

Bonsoir,

Eléments communs avec Objet dictionary

Sub Communs()
  a = Range("r2:r" & [r65000].End(xlUp).Row)
  Set MonDico1 = CreateObject("Scripting.Dictionary")
  For Each c In a
    MonDico1(c) = ""
  Next c
  b = Range("bm2:bm" & [bm65000].End(xlUp).Row)
  Set MonDico2 = CreateObject("Scripting.Dictionary")
  For Each c In b
    If MonDico1.exists(c) Then If Not MonDico2.exists(c) Then MonDico2(c) = ""
  Next c
  [f2].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.keys)
End Sub

JB

 

[moteurV12]

Re : avec l’objet “Dictionary”.

Imprecc BOISGONTIER ca fonctionne MERCI mais ayant plus de 65 000 lignes j'ai adapté comme suit

t1 = Range(Cells(1, "R"), Cells(Rows.Count, "R").End(xlUp))
Set MonDico1 = CreateObject("Scripting.Dictionary")
For Each C In t1
MonDico1(C) = ""
Next C
t2 = Range(Cells(1, "BM"), Cells(Rows.Count, "BM").End(xlUp))
Set MonDico2 = CreateObject("Scripting.Dictionary")
For Each C In t2
If MonDico1.Exists(C) Then If Not MonDico2.Exists(C) Then MonDico2(C) = ""
Next C
[f1].Resize(MonDico2.Count, 1) = Application.Transpose(MonDico2.Keys)


J'ai un autre souci de lenteur sur cette commande qui fait un clearcontents sur les cellules qui ne répondent pas à certains critères, puis je suis obligé de trier pour mettre les lignes vides en bas du tableau, une idée pour faire différemment ??

Set rngA = Range(Cells(1, "DK"), Cells(Rows.Count, "DK").End(xlUp))
For Each cell In rngA
If Cells(cell.Row, "DK").Text = "PAS OK" Then
Cells(cell.Row, "A").ClearContents
Cells(cell.Row, "B").ClearContents
Cells(cell.Row, "C").ClearContents
Cells(cell.Row, "D").ClearContents
Cells(cell.Row, "E").ClearContents

End If
Next


[A:E].Sort [a1], xlAscending, Header:=xlNo
DoEvents

 

[BOISGONTIER]

Re : avec l’objet “Dictionary”.

Suppression de lignes

JB

 

[moteurV12]

Re : avec l’objet “Dictionary”.

Surtout pas justement

 

[moteurV12]

Re : avec l’objet “Dictionary”.

J'ai 100 000 lignes avec des nombres en colonnes A B C D E puis en colonne DK j'ai "OK" ou "PAS OK".

J'aimerai travailler sur un tableau mémoire afin de ne récupérer en A B C D E que les lignes "OK" afin d’accélérer le temps de traitement
Je ni suis pas parvenue avec objet dictionnaire.

Une autre idée ??

 

[Dranreb]

Re : avec l’objet “Dictionary”.

Bonsoir.
Essayez :

CellsColLgnOù([A1:E1], "DK", "=", "PAS OK").ClearContents

Avec :

Function CellsColLgnOù(ByVal CelDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
CellsColLgnOù = Intersect(LignesOù(CelDéb, ColQuoi, Opé, Valeur), CelDéb.EntireColumn)
End Function
Function LignesOù(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
If VarType(Valeur) = vbString Then Valeur = """" & Replace(Valeur, _
   """", """""") & """" Else Valeur = Trim$(Str$(Valeur))
Set LignesOù = LignesOùCondR1C1(LigneDéb, "RC" & ColQuoi & Opé & Valeur)
End Function
Function CellsColCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
Set CellsColCondR1C1 = Intersect(LignesOùCondR1C1(CelDéb, CondR1C1), CelDéb.EntireColumn)
End Function
Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
   Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)
   Set ColTrv = Intersect(.Columns(.Columns.Count + 1), Lignes): End With
ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
ColTrv.Delete xlShiftToLeft
End Function

Maintenant si vous voulez seulement avoir en mémoire dans un tableau les ligne avec "OK" en DK, il n'est peut être pas nécessaire de faire ça pour y arriver. M'est avis que vous auriez intérêt à commencer par charger tout, de toute façon.

 

[moteurV12]

Re : avec l’objet “Dictionary”.

Salut Dranreb et merci de ton aide

Ca plante dans la 1er fonction sur
CellsColLgnOù = Intersect(LignesOù(CelDéb, ColQuoi, Opé, Valeur), CelDéb.EntireColumn)

 

[Dranreb]

Re : avec l’objet “Dictionary”.

Oups. Il faut croire que je n'ai pas assez eu l'occasion de l'utiliser sous cette forme plus modulaire qu'auparavant.
Ajoutez simplement devant: Set
Désolé pour ce défaut de mise au point.

 

[moteurV12]

Re : avec l’objet “Dictionary”.

Ne soyez pas désolé, c'est sympa de m'aider surtout vu l'heure ou le cerveau voudrait ce retirer.

Bon ca fonctionne, mais pas plus rapide que la solution que j'ai présenté plus bas et surtout beaucoup de lignes vides.
Faudrait, sans trier, que les données soient ordonnées sans lignes vides dans l'ordre "naturel".

 

[moteurV12]

Re : avec l’objet “Dictionary”.

je suis parti là dessus mais je n'arrive pas a finaliser

' Set MonDico1 = CreateObject("scripting.dictionary")
' a = [A1K3000]
' For i = 1 To 3000
' CléBase = a(i, 114)
' Clé = CléBase
' indice = 1
' Do While MonDico1.Exists(Clé)
' Clé = CléBase & indice
' indice = indice + 1
' Loop
' MonDico1(Clé) = i
' Next i
' '--recherche (0,03 sec pour 1.000 recherches)
' CléBase = "OK"
' Clé = CléBase
' indice = 1
' Do While MonDico1.Exists(Clé)
' Ligne = MonDico1(Clé)
' Range("A" & indice) = a(Ligne, 1)
' Range("B" & indice) = a(Ligne, 2)
' Range("C" & indice) = a(Ligne, 3)
' Range("D" & indice) = a(Ligne, 4)
' Range("E" & indice) = a(Ligne, 5)
'
' Clé = CléBase & indice
' indice = indice + 1
' Loop

fonctionne pas

 

[Dranreb]

Re : avec l’objet “Dictionary”.

Joignez un fichier que je voie ça.
Normalement les solutions avec ces fonctions sont très rapides car il n'y a aucune boucle.
Il se pourrait bien que vous auriez intérêt à utiliser un dictionnaire arborescent. Mais sans voir exactement ce que vous avez ni ce que vous voulez, je ne vois pas ce que je peux faire de plus. Et puis ce serait plus simple pour y mettre mes modules de service.