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
mais une valeur ne peut pas être commune à plusieurs cellules à moins qu'il ne s'agisse de cellules fusionnées.

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

15testmacro1.xlsm (24.47 Ko)

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 !

n

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
9testmacro1.xlsm (61.05 Ko)

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

Rechercher des sujets similaires à "compter valeurs communes uniques"