Suppression doublon, addition et transposer sans doublon

Le 28/02/2016 à 19:28

Bonjour la communauté.

Après de nombreuse recherche et de test sans succès. Je viens à vous pour avoir de l’aide.

En effet, A partir d'un code vba, j’aimerai supprimer les références en doublon sur les colonnes de A:E, G tout en additionnant les quantités en colonne F.

Le souci principal, ce sont les valeurs adressage en H:Q.

Car pendant la suppression des doublons, il faudra copier les valeurs d’adressage supprimer a la suite des valeurs d’adressage non supprimer ce trouvant en H:Q sur leur ligne correspondante, sans avoir de doublon de ces dernier.

Le fichier joint est un extrait, car ma feuille contient plus de 20000 lignes variables.

En espérant trouver une personne qui se penchera sur ce sujet.

Amicalement

65base-de-recherche.xlsx (12.01 Ko)
Le 28/02/2016 à 19:53

Bonsoir,

Le TCD (tableau croisé dynamique) me semble particulièrement bien adapté

72base-de-recherche01.xlsx (17.68 Ko)
Le 28/02/2016 à 20:19

Merci pour ta réponse rapide.

Ta solution est bonne, mais je ne voulais pas modifier la structure de la page, car j’aimerai avec cette même feuille, adapter au champ de recherche de Sébastien. voila pourquoi j'ai voulu d'une macro.

Mais une question, j’ai entendu dire qu’il ne fallait pas avoir de cellule vide pour effectuer le tableau croisé dynamique. Hors dans ma base, il sera fort probable d’en avoir. Est-ce que le tableau ne présentera pas d’erreur ?

Excuse moi de mon manque de connaissance a ce sujet

je suis a l'écoute de tes conseils

bernard22 a écrit :

Bonsoir,

Le TCD (tableau croisé dynamique) me semble particulièrement bien adapté

Merci pour ta réponse rapide.

Ta solution est bonne, mais je ne voulais pas modifier la structure de la page, car j’aimerai avec cette même feuille, adapter au champ de recherche de Sébastien. voila pourquoi j'ai voulu d'une macro.

Mais une question, j’ai entendu dire qu’il ne fallait pas avoir de cellule vide pour effectuer le tableau croisé dynamique. Hors dans ma base, il sera fort probable d’en avoir. Est-ce que le tableau ne présentera pas d’erreur ?

Excuse moi de mon manque de connaissance a ce sujet

je suis a l'écoute de tes conseils

Le 28/02/2016 à 21:32

Pour moi le TCD ne modifie pas forcément la structure de l'onglet. La plupart du temps on les crée dans un onglet à part onglet (TCD sur mon exemple).

Je ne pense pas que des cellules vides empêchent le tableau de bien fonctionner il suffit le cas échéant de filtrer les valeurs nulles pour une meilleure présentation.

Par contre, quand tu parles "d'adapter au champ de recherche de Sébastien" je ne comprends pas.

Pour ce qui est d'une macro adaptée à ton problème je passe la main......

Bonne continuation.

Le 01/03/2016 à 22:28

Bonsoir michel973, le forum

Pour déterminer les clés du dictionnaire principal, je me suis appuyé sur la colonne A (le Gencod).

A tester dans tous les cas de figure :

Restitution en Feuil1.

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, j As Long, n As Long
Const col As Byte = 7
    ReDim w(1 To 2)
    With Sheets("BASE").Range("a1").CurrentRegion
        a = .Value: n = 1
        ReDim b(1 To UBound(a, 1), 1 To col + 1)
        For j = 1 To col + 1
            b(n, j) = a(n, j)
        Next
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                a(i, 1) = CStr(a(i, 1))
                If Not .exists(a(i, 1)) Then
                    n = n + 1
                    w(1) = n
                    Set w(2) = CreateObject("Scripting.Dictionary")
                    w(2).CompareMode = 1
                    For j = 1 To col
                        b(n, j) = a(i, j)
                    Next
                    For j = col + 1 To UBound(a, 2)
                        If a(i, j) <> "" Then
                            If Not w(2).exists(a(i, j)) Then
                                w(2)(a(i, j)) = Empty
                                If UBound(b, 2) < col + w(2).Count Then
                                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 1)
                                End If
                                b(n, col + w(2).Count) = a(i, j)
                            End If
                        End If
                    Next
                    .Item(a(i, 1)) = w
                Else
                    w = .Item(a(i, 1))
                    b(w(1), 6) = b(w(1), 6) + a(i, 6)
                    For j = col + 1 To UBound(a, 2)
                        If a(i, j) <> "" Then
                            If Not w(2).exists(a(i, j)) Then
                                w(2)(a(i, j)) = Empty
                                If UBound(b, 2) < col + w(2).Count Then
                                    ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 1)
                                End If
                                b(w(1), col + w(2).Count) = a(i, j)
                            End If
                        End If
                    Next
                    .Item(a(i, 1)) = w
                End If
            Next
        End With
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Range("a1").Resize(n, UBound(b, 2))
        .CurrentRegion.Clear
        .Columns(1).NumberFormat = "@"
        .Value = b
        .Font.Name = "calibri"
        .Font.Size = 10
        .VerticalAlignment = xlCenter
        .BorderAround Weight:=xlThin
        .Borders(xlInsideVertical).Weight = xlThin
        With .Rows(1)
            .Font.Size = 11
            .Interior.ColorIndex = 36
            .BorderAround Weight:=xlThin
            .HorizontalAlignment = xlCenter
            .Offset(, col).Resize(, UBound(b, 2) - col).MergeCells = True
        End With
        .Columns(6).NumberFormat = "0.00"
        .Columns.AutoFit
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

Ligne 10, le Gencod 5609021055805 comporte 2 adressages identiques, est-ce normal ?

klin89

Le 03/03/2016 à 02:34

Bonjour,Klin89

bonjour, le forum

J’ai testé la macro. C’est formidable. C’est exactement ce que je cherchai.

Ligne 10, le Gencod 5609021055805 comporte 2 adressages identiques, est-ce normal ?

Non, c’est une erreur de ma part.

Avant de mettre ce sujet comme résolue et sans abuser de votre patience. Je voudrai savoir si vous pouviez déterminer les clés du dictionnaire principal en colonne C. « Référence Image »

Car en effet, c’est la colonne C qui est le pilier de la base de données. Dans la base complète, les autres colonnes peuvent avoir des données manquantes.

Je tiens à vous remercier « Klin89 », à « bernard22 » pour l’aide apporter, ainsi qu’a tout le forum pour les recherches et le travail effectuer à la connaissance de ce fabuleux logiciel Excel.

Le 03/03/2016 à 13:11

Bonjour michel973

Merci pour le retour

L'exercice était clairement exposé et très intéressant à résoudre.

Sinon remplace tous les a(i, 1) par a(i, 3), tu en as 6.

michel973 a écrit :

Dans la base complète, les autres colonnes peuvent avoir des données manquantes.

Ici, je teste l'existence de la clé et est recopié le contenu de la ligne concernée :

If Not .exists(a(i, 1)) Then
                    n = n + 1
                    For j = 1 To col
                        b(n, j) = a(i, j)
                    Next

Par la suite, pour une même clé, s'il y a changement dans le contenu des cellules (A:G), la modification ne sera pas effectuée.

Sinon, on peut définir la clé en s'appuyant sur plusieurs colonnes (concaténation).

klin89

Le 21/04/2016 à 10:53

Bonjour,

Je suis nouveau dans le forum, mais j'étais à la recherche d'une macro qui fait exactement ce que je vois ici mais en la modifiant à ma sauce, j'ai des difficultés à ce niveau de compilation

"ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 1)" j'ai une erreur de memoire.

Mon tableau a 3 colonne A,B,C et j'aimerai seulement verifier les doublons pour la colonne B en additionnant la quantité qui est en C

sans tenir compte de la colonne A.

voici ce que j'ai fait:

Sub test()

Dim a As Variant, b() As Variant, w() As Variant

Dim i As Long, j As Long, n As Long

Const col As Byte = 1

ReDim w(1 To 2)

With Sheets("art-lib").Range("B:C")

a = .Value: n = 1

ReDim b(1 To UBound(a, 1), 1 To col + 1)

For j = 1 To col + 1

b(n, j) = a(n, j)

Next

With CreateObject("Scripting.Dictionary")

.CompareMode = 1

For i = 2 To UBound(a, 1)

a(i, 1) = CStr(a(i, 1))

If Not .exists(a(i, 1)) Then

n = n + 1

w(1) = n

Set w(2) = CreateObject("Scripting.Dictionary")

w(2).CompareMode = 1

For j = 1 To col

b(n, j) = a(i, j)

Next

For j = col + 1 To UBound(a, 2)

If a(i, j) <> "" Then

If Not w(2).exists(a(i, j)) Then

w(2)(a(i, j)) = Empty

If UBound(b, 2) < col + w(2).Count Then

ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 1)

End If

b(n, col + w(2).Count) = a(i, j)

End If

End If

Next

.Item(a(i, 1)) = w

Else

w = .Item(a(i, 1))

b(w(1), 2) = b(w(1), 2) + a(i, 2)

For j = col + 1 To UBound(a, 2)

If a(i, j) <> "" Then

If Not w(2).exists(a(i, j)) Then

w(2)(a(i, j)) = Empty

If UBound(b, 2) < col + w(2).Count Then

ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 1)''''Problème ici""

End If

b(w(1), col + w(2).Count) = a(i, j)

End If

End If

Next

.Item(a(i, 1)) = w

End If

Next

End With

End With

Application.ScreenUpdating = False

With Sheets("OccurenceLibelle").Range("a1").Resize(n, UBound(b, 2))

.CurrentRegion.Clear

.Columns(1).NumberFormat = "@"

.Value = b

.Font.Name = "calibri"

.Font.Size = 10

.VerticalAlignment = xlCenter

.BorderAround Weight:=xlThin

.Borders(xlInsideVertical).Weight = xlThin

With .Rows(1)

.Font.Size = 11

.Interior.ColorIndex = 36

.BorderAround Weight:=xlThin

.HorizontalAlignment = xlCenter

.Offset(, col).Resize(, UBound(b, 2) - col).MergeCells = True

End With

.Columns(6).NumberFormat = "0.00"

.Columns.AutoFit

.Parent.Activate

End With

Application.ScreenUpdating = True

End Sub

Le 22/04/2016 à 19:48
Colos a écrit :

Bonjour,

Je suis nouveau dans le forum, mais j'étais à la recherche d'une macro qui fait exactement ce que je vois ici mais en la modifiant à ma sauce, j'ai des difficultés à ce niveau de compilation

"ReDim Preserve b(1 To UBound(b, 1), 1 To UBound(b, 2) + 1)" j'ai une erreur de memoire.

Bonjour,

tu dois ouvrir ton propre fil de discussion et y mettre non pas le code, ni une image, mais une copie identique à ton vrai fichier mais anonymisé

P.

Le 24/04/2016 à 20:31

Bonjour patrick1957 ,

Je comprends très bien ce que tu dis, je pense qu'il ne faut pas créer une demande sur un sujet qui a été peut être résolu

mais si tu veux je le ferai mais, je suis sûr que certains m'orienteront vers cette discussion.

Cordialement.

Rechercher des sujets similaires à "suppression doublon addition transposer"