Fusion/addition doublons

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion seblap47
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
S

seblap47

Guest
Bonjour

J'ai une feuille excel qui ressemble à ça avec au moins 500 lignes.

1.jpg

Comment à l'aide d'une macro obtenir ça dans une autre feuille ?

2.jpg

Merci
 

Pièces jointes

  • 1.jpg
    1.jpg
    16.8 KB · Affichages: 57
  • 1.jpg
    1.jpg
    16.8 KB · Affichages: 59
  • 2.jpg
    2.jpg
    11.2 KB · Affichages: 48
  • 2.jpg
    2.jpg
    11.2 KB · Affichages: 47
Trier par date Trier par votes
Re : Fusion/addition doublons

Bonjour,

Exemple

Code: 
Sub SousTotal()
  a = Range("A2:D" & [a65000].End(xlUp).Row)
  Dim b(): ReDim b(1 To UBound(a), 1 To UBound(a, 2))
  i = 1: j = 0
  Do While i <= UBound(a)
    j = j + 1: b(j, 2) = a(i, 2): b(j, 3) = a(i, 3): b(j, 4) = a(i, 4)
    Do While a(i, 2) = b(j, 2)
      b(j, 1) = b(j, 1) + a(i, 1)
      i = i + 1: If i > UBound(a) Then Exit Do
    Loop
  Loop
 [K2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

JB
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Fusion/addition doublons

Bonjour,

Effectivement avec des tableaux croisé dynamiques ça fonctionne.
Par contre pour plus de praticité, je préférerai des macros.
Le but ce n'est pas de générer un autre tableau mais de fusionner les doublons et d'additionner les valeurs de la colonne A dans le feuille active.

Merci

Sébastien
 
Vote positif 0 Vote négatif
Re : Fusion/addition doublons

Bonsoir le forum, 🙂

Sur quelles colonnes se base t-on pour déterminer tes doublons ?
J'ai pris en compte les colonnes 2, 3 et 4
VB: 
Sub Essai()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    a = Range("A1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = Join$(Array(a(i, 2), a(i, 3), a(i, 4)), Chr(2))
            If Not .exists(txt) Then
                n = n + 1
                .Item(txt) = n
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            Else
                a(.Item(txt), 1) = a(.Item(txt), 1) + a(i, 1)
            End If
        Next
    End With
    'restitution et mise en forme
    With Sheets(2).Cells(1)
        .CurrentRegion.Clear
        .Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            With .Rows(1)
                .Font.Bold = True
                .Interior.ColorIndex = 40
                .BorderAround Weight:=xlThin
            End With
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            '.Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub
klin89
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Fusion/addition doublons

klin89 à dit:
Bonsoir le forum, 🙂

Sur quelles colonnes se base t-on pour déterminer tes doublons ?
J'ai pris en compte les colonnes 2, 3 et 4
VB: 
Sub Essai()
Dim a, i As Long, j As Long, txt As String, n As Long
    Application.ScreenUpdating = False
    a = Range("A1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            txt = Join$(Array(a(i, 2), a(i, 3), a(i, 4)), Chr(2))
            If Not .exists(txt) Then
                n = n + 1
                .Item(txt) = n
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            Else
                a(.Item(txt), 1) = a(.Item(txt), 1) + a(i, 1)
            End If
        Next
    End With
    'restitution et mise en forme
    With Sheets(2).Cells(1)
        .CurrentRegion.Clear
        .Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            With .Rows(1)
                .Font.Bold = True
                .Interior.ColorIndex = 40
                .BorderAround Weight:=xlThin
            End With
            .Font.Name = "calibri"
            .VerticalAlignment = xlCenter
            .HorizontalAlignment = xlCenter
            .Borders(xlInsideVertical).Weight = xlThin
            .BorderAround Weight:=xlThin
            '.Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub
klin89
Cliquez pour agrandir...

Bonsoir,

Merci ce code fonctionne parfaitement !
C'est bien les colonnes 2,3 et 4 qu"il faut prendre en compte.

Merci encore 🙂

Sébastien
 
Dernière modification par un modérateur:
Vote positif 0 Vote négatif
Re : Fusion/addition doublons

Bonsoir à tous

seblap47[highlight] [Bienvenue sur le forum][/code]
Vous pouvez m'expliquer où est le problème ?
Je n'ai pas le droit de poster la même question sur plusieurs forum ?
Cliquez pour agrandir...
Ce n'est pas un problème mais une question d'usage.
Multipostage — Wikipédia
Il est apprécié de savoir qu'une même question a été posée sur plusieurs forums (en le signalant par un lien hypertexe)
Cela a notamment l'avantage d'éviter la(les) situation(s) suivante(s):
Tu poses ta question sur plusieurs forums puis tu la postes sur XLD sans signaler tes autres posts.
Un XLDnaute tombe sur ta question et essaie d'y répondre (donc il passe du temps pour cela)
Puis il se rend compte que :
1) il poste une réponse similaire à une réponse déposée sur autre forum bien avant la sienne
(en gros, il a perdu son temps à répondre à une question qui a déjà sa réponse ailleurs)
2) il se rend compte que le demandeur ne suit plus son fil sur XLD parce qu'il a une réponse ailleurs et ne daigne pas venir le signaler sur XLD (car une question et sa solution intéresse potentiellement la communauté Excelienne et donc vaut d'être partagée avec tous)

J'espère avoir éclairer ta lanterne sur ce point 😉
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Fusion/addition doublons

Bonjour,

Il me semble que ma réponse au post #3 donnait le (bon) résultat

Code: 
Sub SousTotalJB()
  Set champ = Range("A2:D" & [a65000].End(xlUp).Row)
  champ.Sort key1:=[b2]
  a = champ.Value
  Dim b(): ReDim b(1 To UBound(a), 1 To UBound(a, 2))
  i = 1: j = 0
  Do While i <= UBound(a)
    j = j + 1: b(j, 2) = a(i, 2): b(j, 3) = a(i, 3): b(j, 4) = a(i, 4)
    Do While a(i, 2) = b(j, 2)
      b(j, 1) = b(j, 1) + a(i, 1)
      i = i + 1: If i > UBound(a) Then Exit Do
    Loop
  Loop
  [A1:D1].Copy Sheets("feuil2").[f1]
  Sheets("feuil2").[f2].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Autre solution avec Dictionary

Code: 
Sub SousTotalJB()
  Set d1 = CreateObject("Scripting.Dictionary")
  a = Range("A2:D" & [a65000].End(xlUp).Row)
  For i = LBound(a) To UBound(a)
    d1(a(i, 2)) = ""
  Next i
  Dim b():  ReDim b(1 To d1.Count, 1 To UBound(a, 2))
  For ligne = LBound(a) To UBound(a)
     p = Application.Match(a(ligne, 2), d1.keys, 0)
     b(p, 1) = b(p, 1) + a(ligne, 1)
     For k = 2 To 4: b(p, k) = a(ligne, k): Next k
  Next ligne
  Sheets("feuil2").[f2].Resize(UBound(b), UBound(b, 2)) = b
  [A1:D1].Copy Sheets("feuil2").[f1]
End Sub


JB
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Fusion/addition doublons

BOISGONTIER à dit:
Bonjour,

Il me semble que ma réponse au post #3 donnait le (bon) résultat

Code: 
Sub SousTotalJB()
  a = Range("A2:D" & [a65000].End(xlUp).Row)
  Dim b(): ReDim b(1 To UBound(a), 1 To UBound(a, 2))
  i = 1: j = 0
  Do While i <= UBound(a)
    j = j + 1: b(j, 2) = a(i, 2): b(j, 3) = a(i, 3): b(j, 4) = a(i, 4)
    Do While a(i, 2) = b(j, 2)
      b(j, 1) = b(j, 1) + a(i, 1)
      i = i + 1: If i > UBound(a) Then Exit Do
    Loop
  Loop
  [A1:D1].Copy Sheets("feuil2").[f1]
  Sheets("feuil2").[f2].Resize(UBound(b), UBound(b, 2)) = b
End Sub


JB
Cliquez pour agrandir...

Bonsoir,

Désolé pour le retard.
J'ai testé tout les codes et effectivement le votre fonctionne parfaitement.
Merci beaucoup, c'est parfait.

Sébastien
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

N
  • Résolu(e)
XL 2013 Somme VBA sur plusieurs ligne
Réponses
8
Affichages
233
Nico77
N
Caninge
  • Question Question
XL 2019 Doublons et MFC
2
Réponses
16
Affichages
478
Caninge
Caninge
D
  • Question Question
XL 2016 Création d'un tableau récapitulatif
Réponses
6
Affichages
264
AtTheOne
AtTheOne
R
  • Question Question
Microsoft 365 Formule qui sélectionne un ligne et qui récupère la ligne en-dessous
2
Réponses
29
Affichages
575
roro67200
R
L
  • Résolu(e)
Microsoft 365 Erreur d'exécution 1004 : la méthode select de la classe Worksheet a échoué
Réponses
7
Affichages
166
LaurentVasseur
L
S
  • Résolu(e)
Microsoft 365 Calcul intérêt compte courant
Réponses
14
Affichages
272
sylvanu
sylvanu
C
  • Résolu(e)
Microsoft 365 Recherche de doublons à plusieurs critères sur plusieurs colonnes
Réponses
4
Affichages
301
job75
job75
M
  • Question Question
Microsoft 365 Chercher dernière valeur d'une ligne mais avec une particularité
Réponses
4
Affichages
249
Marie.
M
M
  • Question Question
XL 2016 pb création de tableau par macro
Réponses
10
Affichages
383
ChTi160
ChTi160
F
  • Question Question
XL 2016 travail sur tableau
2 3 4
Réponses
55
Affichages
2 K
finarobert
F
Claudy
  • Question Question
Microsoft 365 Mozaïque photos
2
Réponses
17
Affichages
519
job75
job75
D
  • Résolu(e)
XL 2019 plusieurs critères
Réponses
5
Affichages
162
Dand87
D
Dudu2
  • Question Question
XL 2021 VBA - Quelle fenêtre (non Excel) était active juste avant
2
Réponses
22
Affichages
499
patricktoulon
patricktoulon
C
  • Question Question
Microsoft 365 Instruction OptionMacros
Réponses
2
Affichages
158
patricktoulon
patricktoulon
R
  • Question Question
XL pour MAC Accès aux zones d'un tableau
Réponses
10
Affichages
472
TooFatBoy
TooFatBoy
I
  • Question Question
Microsoft 365 le choix entre les fonctions Filtre ou RechercheX ou Index equiv
Réponses
4
Affichages
309
ALS35
A
P
  • Résolu(e)
XL 2021 Comment détecter la modification MANUELLE d'une cellule dans une feuille ?
Réponses
3
Affichages
261
PRy
P
Y
  • Question Question
Power Query Besoin d'aide pour configurer un power query
Réponses
3
Affichages
186
alexga78
A
B
  • Résolu(e)
XL 2021 VBA : activer une feuille dont le nom est la valeur d'une cellule
Réponses
2
Affichages
113
berru76
B
treza88
  • Question Question
XL 2021 Encadrement de cellule sur tableau dynamique
2
Réponses
21
Affichages
1 K
Phil69970
Phil69970
Retour