Supprimer doublons ou comptage entrée unique

Le 15/06/2018 à 16:11

bonjour,

j'essaye d'exploiter des données de logs avec des dates identiques qui ne me servent a rien, or je ne sais pas comment les supprimer.

mon objectif c'est de connaitre, pour chaque user (colonne A), le nombre de jours différents (colonne D) où il s'est connecté à un site (colonne C). l'idéal pour moi serait d'avoir un comptage, mais si je dois obligatoirement supprimer les lignes inutiles, ce sera déja génial.

merci beaucoup pour votre aide

Z

16remove-duplicates-date.xlsx (10.91 Ko)
Le 15/06/2018 à 16:50

Bonjour,

Si l'idée est de supprimer simplement les doublons :

Onglet données>Outils de données > Supprimer les doublons.

@+

Le 15/06/2018 à 16:54

merci. pensez vous que cette methode supprime les heures différentes pour le meme jour, meme site ?

Le 15/06/2018 à 16:56

Je ne pense pas mais je vous laisse tester

Le 15/06/2018 à 17:21

et bien vous avez raison, cela ne marche pas.

je ne comprend pas trop votre démarche, mais merci quand meme

Le 15/06/2018 à 20:36

bonjour

un essai /contribution en sheet 2

7exelsior75.xlsx (13.29 Ko)

cordialement

Le 15/06/2018 à 20:43

Bonjour,

Bonjour tulipe_4

Une proposition à étudier.

Cdlt.

11remove-duplicates-date.xlsx (23.51 Ko)
Le 15/06/2018 à 23:09

Bonsoir à tous,

Une autre version, restitution en Sheet2

Option Explicit
Sub test()
Dim a, i As Long, n As Long, dico As Object, e, v
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Sheet1").Range("a1").CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 1)) Then
            Set dico(a(i, 1)) = _
            CreateObject("Scripting.Dictionary")
            dico(a(i, 1)).CompareMode = 1
        End If
        If Not dico(a(i, 1)).exists(a(i, 3)) Then
            Set dico(a(i, 1))(a(i, 3)) = _
            CreateObject("Scripting.Dictionary")
        End If
        If Not dico(a(i, 1))(a(i, 3)).exists(Split(a(i, 4))(0)) Then
            dico(a(i, 1))(a(i, 3))(Split(a(i, 4))(0)) = _
            Array(a(i, 1), a(i, 2), a(i, 3), Split(a(i, 4))(0))
        End If
    Next
    'restitution
    Application.ScreenUpdating = False
    With Sheets(2)
        .Cells.Clear
        For Each e In dico.keys
            For Each v In dico(e).keys
                If UBound(Application.Transpose(Application.Index(dico(e)(v).items, 0, 0)), 2) = 1 Then
                    .Cells(1).Offset(n).Resize(1, _
                                               UBound(Application.Index(dico(e)(v).items, 0, 0))).Value = _
                                               Application.Index(dico(e)(v).items, 0, 0)
                Else
                    .Cells(1).Offset(n).Resize(UBound(Application.Index(dico(e)(v).items, 0, 0), 1), _
                                               UBound(Application.Index(dico(e)(v).items, 0, 0), 2)).Value = _
                                               Application.Index(dico(e)(v).items, 0, 0)
                End If
                n = n + dico(e)(v).Count
            Next
        Next
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Le 16/06/2018 à 10:06

Re excelsior75,

Si tu veux les compter, essaie ceci :

Option Explicit
Sub test1()
Dim a, w(), i As Long, n As Long, ub1 As Long, ub2 As Byte, dico As Object, e, v
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Sheet1").Range("a1").CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 1)) Then
            Set dico(a(i, 1)) = _
            CreateObject("Scripting.Dictionary")
            dico(a(i, 1)).CompareMode = 1
        End If
        If Not dico(a(i, 1)).exists(a(i, 3)) Then
            Set dico(a(i, 1))(a(i, 3)) = _
            CreateObject("Scripting.Dictionary")
        End If
        If Not dico(a(i, 1))(a(i, 3)).exists(Split(a(i, 4))(0)) Then
            dico(a(i, 1))(a(i, 3))(Split(a(i, 4))(0)) = _
            Array(a(i, 1), a(i, 2), a(i, 3), Split(a(i, 4))(0), 1)
        Else
            w = dico(a(i, 1))(a(i, 3))(Split(a(i, 4))(0))
            w(4) = w(4) + 1
            dico(a(i, 1))(a(i, 3))(Split(a(i, 4))(0)) = w
        End If
    Next
    'restitution et mise en forme
    Application.ScreenUpdating = False
    With Sheets(2)
        .Cells.Clear
        For Each e In dico.keys
            For Each v In dico(e).keys
                If UBound(Application.Transpose(Application.Index(dico(e)(v).items, 0, 0)), 2) = 1 Then
                    'si tableau 1 dimension
                    ub1 = 1
                    ub2 = UBound(Application.Index(dico(e)(v).items, 0, 0))
                Else
                    'si tableau 2 dimensions
                    ub1 = UBound(Application.Index(dico(e)(v).items, 0, 0), 1)
                    ub2 = UBound(Application.Index(dico(e)(v).items, 0, 0), 2)
                End If
                With .Cells(1).Offset(n).Resize(ub1, ub2)
                    .Value = Application.Index(dico(e)(v).items, 0, 0)
                    .BorderAround Weight:=xlThin
                End With
                n = n + dico(e)(v).Count
            Next
        Next
        With .UsedRange
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .Font.Name = "calibri"
            .Font.Size = 10
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

klin89

Le 18/06/2018 à 11:03

Jean-Eric, tulipe4 et Klin89, merci beaucoup pour vos solutions.

Le dernier script correspond bien a mes besoins. Pensez vous qu'il est possible de visualiser le nombre de jours différents dans la derniere colonne ?

capture

ça donnerait : jacques mexico pomme 1, jacques mexico poire 2, patrick geneve pomme 3 etc..

Le 19/06/2018 à 10:30

bonjour

j'ai oublié de préciser que mon fichier fait +/- 500000 lignes.

Lorsque je tente de faire tourner le script j'ai le message erreur Subscript out of range

Sauriez vous comment je peux le modifier ?

Merci beaucoup

z

Le 20/06/2018 à 14:18

re excelsior75,

Pour répondre à la nouvelle question, j'ai rajouté une boucle :

500 000 lignes, ça risque d'être un peu long 

Option Explicit
Sub test2()
Dim a, w(), i As Long, n As Long, ub1 As Long, ub2 As Byte, dico As Object, e, v, s
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    a = Sheets("Sheet1").Range("a1").CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        If Not dico.exists(a(i, 1)) Then
            Set dico(a(i, 1)) = _
            CreateObject("Scripting.Dictionary")
            dico(a(i, 1)).CompareMode = 1
        End If
        If Not dico(a(i, 1)).exists(a(i, 3)) Then
            Set dico(a(i, 1))(a(i, 3)) = _
            CreateObject("Scripting.Dictionary")
        End If
        If Not dico(a(i, 1))(a(i, 3)).exists(Split(a(i, 4))(0)) Then
            dico(a(i, 1))(a(i, 3))(Split(a(i, 4))(0)) = _
            Array(a(i, 1), a(i, 2), a(i, 3), Split(a(i, 4))(0), 1, Empty)
        Else
            w = dico(a(i, 1))(a(i, 3))(Split(a(i, 4))(0))
            w(4) = w(4) + 1
            dico(a(i, 1))(a(i, 3))(Split(a(i, 4))(0)) = w
        End If
    Next
    'rajout de la nouvelle boucle
    For Each e In dico.keys
        For Each v In dico(e).keys
            For Each s In dico(e)(v).keys
                w = dico(e)(v)(s)
                w(5) = dico(e)(v).Count
                dico(e)(v)(s) = w
                Exit For
            Next
        Next
    Next
    'restitution et mise en forme
    Application.ScreenUpdating = False
    With Sheets(2)
        .Cells.Clear
        For Each e In dico.keys
            For Each v In dico(e).keys
                If UBound(Application.Transpose(Application.Index(dico(e)(v).items, 0, 0)), 2) = 1 Then
                    'si tableau 1 dimension
                    ub1 = 1
                    ub2 = UBound(Application.Index(dico(e)(v).items, 0, 0))
                Else
                    'si tableau 2 dimensions
                    ub1 = UBound(Application.Index(dico(e)(v).items, 0, 0), 1)
                    ub2 = UBound(Application.Index(dico(e)(v).items, 0, 0), 2)
                End If
                With .Cells(1).Offset(n).Resize(ub1, ub2)
                    .Value = Application.Index(dico(e)(v).items, 0, 0)
                    .BorderAround Weight:=xlThin
                End With
                n = n + dico(e)(v).Count
            Next
        Next
        With .UsedRange
            .VerticalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .Font.Name = "calibri"
            .Font.Size = 10
        End With
    End With
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Concernant l'erreur, il faut fournir ton fichier

klin89

Le 28/06/2018 à 09:42

merci beaucoup klin, le dernier message remplit parfaitement tous mes besoins et le message erreur que j'obtenais etait une erreur de ma part.

1000 mercis !

Rechercher des sujets similaires à "supprimer doublons comptage entree unique"