Compter valeurs communes et uniques
Bonjour,
Je souhaite récupérer le nombre de valeurs communes et uniques selon des critères dates.
J’ai 2 colonnes, en colonne A une liste de date, et en colonne B des données avec des doublons.,,,,
D’apres une date fixée dans une cellule, je dois remonter 3 dates juste avant la date fixée.
Ces critères dates une fois définies, je dois rechercher des valeurs communes et des valeurs uniques pour les afficher dans des cellules.
Est ce que la méthode Dictionary peut être utilisée?
Je vous remercie
Bonjour,,
...je dois rechercher des valeurs communes et des valeurs uniques...
Est ce que la méthode Dictionary peut être utilisée?
Oui on peut utiliser l'objet Dictionary pour compter les différentes valeurs contenues dans une plage de cellules.
- lorsqu'on n'en trouve qu'une : elle est unique
- lorsqu'on en trouve plusieurs : elle est multiple
Exemple :
Option Explicit
Sub Test()
Dim u As Object, m As Object
Dim w As Workbook
Dim r As Range, c As Range
Dim t As Variant, i As Long
t = Application.Transpose(ActiveSheet.Range("B1:B80").Value) 'à adapter
Set u = CreateObject("Scripting.Dictionary")
Set m = CreateObject("Scripting.Dictionary")
For i = LBound(t) To UBound(t)
If Not u.Exists(t(i)) Then
u(t(i)) = 1
Else
If Not m.Exists(t(i)) Then
m(t(i)) = 2
Else
m(t(i)) = m(t(i)) + 1
End If
End If
Next i
Set w = Application.Workbooks.Add(xlWBATWorksheet)
Set r = w.Worksheets(1).Range("A1:D1")
With r
'Titres
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Cells(1, 1).Formula = "Valeurs uniques : " & u.Count
.Cells(1, 3).Formula = "Valeurs multiples : " & m.Count
.Cells(1, 4).Formula = "Quantité"
'Listes des valeurs
.Offset(1).Cells(1, 1).Resize(u.Count) = Application.Transpose(u.Keys)
.Offset(1).Cells(1, 3).Resize(m.Count) = Application.Transpose(m.Keys)
.Offset(1).Cells(1, 4).Resize(m.Count) = Application.Transpose(m.Items)
.EntireColumn.AutoFit
End With
End Sub
Merci, bonne base de travail.
Je vais l'essayer...
Cordialement
J'ai essayer d'adapter votre code sans trop de succès
il est basé sur une seule colonne
Également, j'ai beau faire du pas à pas avec espions sur les variables, mais cela reste compliqué
Pouvez vous, maider à mieux comprendre le code, après j'essayerai de l'adapter
Merci
Pouvez vous m'aider pour interpréter le fonctionnent des 2 dicos SVP
If Not m.Exists(t(i)) Then
m(t(i)) = 2
Else
m(t(i)) = m(t(i)) + 1
Bonjour,
t(i) est une clé du dictionnaire
If Not m.Exists(t(i)) Then
si la clé n'existe pas dans le dictionnaire
m(t(i)) = 2
on ajoute la clé au dictionnaire avec pour valeur associée 2 (e.i. clé = t(i) et item = 2)
on aurait aussi pu écrire m.Add t(i), 2 qui est une syntaxe équivalente mais qui produit une erreur quand la clé déjà.
Else
et sinon
m(t(i)) = m(t(i)) + 1
on affecte à cette clé (m(clé)=) l'ancienne valeur + 1 (m(clé)+1) (i.e item = 3 puis 4 ...)
Des exemples ici : http://boisgontierjacques.free.fr/pages_site/Dictionnaire.htm
Merci pour ce suivi,
j'ai passé l'après midi sur le site
, je comprends un peu mieux les dico.
Par contre, je n'ai pas trouve de solution :
compter les valeurs uniques et communes par date, sur mes 3 dates, il faut que je trouve ces valeurs.
Date N-1 29/11/2018
nbre d'erreur commune 1 GD-12-15
nbre d'erreur unique 2 AC-15-12 GI-25-13
Date N-2 23/11/2018
nbre d'erreur commune 2 GI-33-15 GD-12-15
nbre d'erreur unique 1 AB-10-20
Date N-3 22/11/2018
nbre d'erreur commune 2 GI-33-15 GD-12-15
nbre d'erreur unique 0
Est ce que tu peux m'aider ?
Merci
Bonjour,
Exemple pour trouver les 3 dates :
' Note : il faut activer les références (dans Outils > Références ...) à :
' - Microsoft Scripting Runtime
Option Explicit
Sub Maj_Etude()
' Mise à jour de l'étude
Dim dic As Dictionary 'Dictionnaire
Dim clé As Variant 'Clé de dictionnaire
Dim tbl As Variant 'Tableau des données
Dim t_D As Variant 'Tableau des dates (triées)
Dim d_E As Date, d_T As Date 'Date étude, Date tableau
Dim L As Long, C As Long 'Ligne, Colonne
Dim i As Long 'index
With Worksheets("MODELE_1")
' Date étude
d_E = .Range("C2").Value
' Transferer les données dans un tableau
tbl = .Range("B22").CurrentRegion.Value
End With
' Mémoriser dans un dictionnaire chaque date inférieure à la date d'étude
Set dic = New Dictionary
For L = LBound(tbl, 1) + 1 To UBound(tbl, 1)
d_T = tbl(L, 1)
If d_T < d_E Then dic(d_T) = ""
Next L
' Trier le dictionnaire dans l'ordre décroissant
Call TriDownDicoKeys(dic)
' Ne conserver que les 3 dates les plus récentes
For Each clé In dic.Keys
i = i + 1
If i > 3 Then dic.Remove clé
Next clé
' Créer un tableau des dates (si besoin)
t_D = dic.Keys
'...
End Sub
Public Sub TriDownDicoKeys(dic As Dictionary)
' Tri rapide (Quick sort) d'un Dictionnaire dans l'ordre décroissant des clés
Dim tmp() As Variant
Dim clé As Variant
Dim ctr As Long
ReDim tmp(1 To dic.Count, 1 To 2)
ctr = 1
For Each clé In dic.Keys
tmp(ctr, 1) = clé
tmp(ctr, 2) = dic(clé)
ctr = ctr + 1
Next clé
Call TriDownTable2col(tmp, LBound(tmp, 1), UBound(tmp, 1))
dic.RemoveAll
For ctr = 1 To UBound(tmp, 1)
dic(tmp(ctr, 1)) = tmp(ctr, 2)
Next ctr
End Sub
Private Sub TriDownTable2col(table As Variant, premier As Integer, dernier As Integer)
' Tri rapide (Quick sort) récursif dans l'ordre décroissant d'un tableau(1 to n, 1 to 2)
Dim pivot As Variant
Dim temp As Variant
Dim p As Integer
Dim d As Integer
p = premier
d = dernier
pivot = table((p + d) \ 2, 1)
Do
Do While table(p, 1) > pivot
p = p + 1
Loop
Do While pivot > table(d, 1)
d = d - 1
Loop
If p <= d Then
'permuter
temp = table(p, 1): table(p, 1) = table(d, 1): table(d, 1) = temp
temp = table(p, 2): table(p, 2) = table(d, 2): table(d, 2) = temp
p = p + 1
d = d - 1
End If
Loop While p <= d
'Appels récursifs
If p < dernier Then Call TriDownTable2col(table, p, dernier)
If premier < d Then Call TriDownTable2col(table, premier, d)
End Sub
Merci pour ce code , que j'ai modifié.
Cependant, je bloque sur les conditions de comptage avec les dates :
Sub ErreursCommunesUniques()
Dim DateN_3, DateN_1, ValeurLue As String
Dim u As Object, m As Object
Dim w As Workbook
Dim r As Range, C As Range
Dim t As Variant, i As Long
t = Application.Transpose(ActiveSheet.Range("D2:D302").Value)
Set u = CreateObject("Scripting.Dictionary")
Set m = CreateObject("Scripting.Dictionary")
For i = LBound(t) To UBound(t)
'Si i y auarait des cellules vides, on passe à la cellule suivante
If t(i) = "" Then GoTo saut
'On ne comptabilise que les codes défauts de type erreur
If Cells(i, 2).Offset(1, 0).Value <> "Error" Then GoTo saut
'Je prends seulement les dates comprises entre t_D(0) et t_D(2), soit Date N-1 et Date N-3
If Format(Cells(i, 3).Offset(1, 0), "dd/mm/yyyy") >= t_D(2) And Format(Cells(i, 3).Offset(1, 0), "dd/mm/yyyy") <= t_D(0) Then GoTo saut
'si la clé n'existe pas dans le dictionnaire des valeurs uniques
If Not u.Exists(t(i)) Then
u(t(i)) = 1 '
Else
'si la clé n'existe pas dans le dictionnaire des valeurs communes
If Not m.Exists(t(i)) Then
'on ajoute la clé au dictionnaire avec pour valeur associée 2 (e.i. clé = t(i) et item = 2)
'(2 car elle existe déjà une fois dans le première dictionnaire u)
m(t(i)) = 2
Else
'on affecte à cette clé (m(clé)=) l'ancienne valeur + 1 (m(clé)+1) (i.e item = 3 puis 4 ...)
m(t(i)) = m(t(i)) + 1
End If
End If
saut:
Next i
t_U = u.Keys
e = t_D
With Sheets("histo")
'Titres
.Cells(1, 1).Formula = "Valeurs uniques : " & u.Count
.Cells(1, 3).Formula = "Valeurs multiples : " & m.Count
.Cells(1, 4).Formula = "Quantité"
'Listes des valeurs
.Cells(2, 1).Resize(u.Count) = Application.Transpose(u.Keys)
.Cells(2, 3).Resize(m.Count) = Application.Transpose(m.Keys)
.Cells(2, 4).Resize(m.Count) = Application.Transpose(m.items)
' .Offset(1).Cells(1, 1).Resize(u.Count) = Application.Transpose(u.Keys)
' .Offset(1).Cells(1, 3).Resize(m.Count) = Application.Transpose(m.Keys)
' .Offset(1).Cells(1, 4).Resize(m.Count) = Application.Transpose(m.items)
'.EntireColumn.AutoFit
End With
End Sub
Merci !
Bonsoir,
j’avance doucement, j'avais visiblement un problème de compatibilité de variable Variant/date (t_D) contre string/date,
C'est résolu, mais certaines dates passent à l'as ...
Sub ErreursCommunesUniques()
Dim u As Object, m As Object
Dim w As Workbook
Dim r As Range, C As Range
Dim t, DateN_3, DateN_1, DateLue As Variant, i As Long
t = Application.Transpose(ActiveSheet.Range("D2:D302").Value)
Set u = CreateObject("Scripting.Dictionary")
Set m = CreateObject("Scripting.Dictionary")
For i = LBound(t) To UBound(t)
'Si i y auarait des cellules vides, on passe à la cellule suivante
If t(i) = "" Then GoTo saut
'On ne comptabilise que les codes défauts de type erreur
If Cells(i, 2).Offset(1, 0).Value <> "Error" Then GoTo saut
' Cells(i, 3).Offset(1, 0).Select
'Je prends seulement les dates comprises entre t_D(0) et t_D(2), soit Date N-1 et Date N-3
DateLue = Format(Cells(i, 3).Offset(1, 0), "dd/mm/yyyy")
DateN_1 = Format(t_D(0), "dd/mm/yyyy")
DateN_3 = Format(t_D(2), "dd/mm/yyyy")
'================ Pourquoi,certaines dates ne sont pas prises en compte....
If DateLue >= DateN_3 And DateLue <= DateN_1 Then
Range("E" & i).Offset(1, 0).Value = "OK"
'================ Pourquoi,certaines dates ne sont pas prises en compte....
'si la clé n'existe pas dans le dictionnaire des valeurs uniques
If Not u.Exists(t(i)) Then
u(t(i)) = 1 '
Else
'si la clé n'existe pas dans le dictionnaire des valeurs communes
If Not m.Exists(t(i)) Then
'on ajoute la clé au dictionnaire avec pour valeur associée 2 (e.i. clé = t(i) et item = 2)
'(2 car elle existe déjà une fois dans le première dictionnaire u)
m(t(i)) = 2
Else
'on affecte à cette clé (m(clé)=) l'ancienne valeur + 1 (m(clé)+1) (i.e item = 3 puis 4 ...)
m(t(i)) = m(t(i)) + 1
End If
End If
End If
'End If
saut:
Next i
t_U = u.Keys
e = t_D
With Sheets("histo")
'Titres
.Cells(1, 1).Formula = "Valeurs uniques : " & u.Count
.Cells(1, 3).Formula = "Valeurs multiples : " & m.Count
.Cells(1, 4).Formula = "Quantité"
'Listes des valeurs
.Cells(2, 1).Resize(u.Count) = Application.Transpose(u.Keys)
.Cells(2, 3).Resize(m.Count) = Application.Transpose(m.Keys)
.Cells(2, 4).Resize(m.Count) = Application.Transpose(m.items)
' .Offset(1).Cells(1, 1).Resize(u.Count) = Application.Transpose(u.Keys)
' .Offset(1).Cells(1, 3).Resize(m.Count) = Application.Transpose(m.Keys)
' .Offset(1).Cells(1, 4).Resize(m.Count) = Application.Transpose(m.items)
'.EntireColumn.AutoFit
End With
End Sub
Pb de comparaison de date résolue (encore un pb de type et format)..
'On place les valeurs ds des variables pour avoir le même type pour comparaison
DateLue = Cells(i, 3).Offset(1, 0)
DateN_1 = t_D(0) + 0.99999 'pour avoir une date butée avec les minutes et secondes, ex 27/11/18 23:59
DateN_3 = t_D(2)
'Je prends seulement les dates comprises entre t_D(0) et t_D(2), soit Date N-1 et Date N-3
If DateLue >= DateN_3 And DateLue <= DateN_1 Then
Reste à comptabiliser les erreurs par section de date ...
Cordialement