Fusionner cellules identiques

paritec a écrit :

Bonjour Eddyeddy patrick le forum

Voilà avec les deux dernières colonnes

a+

Papou

https://www.cjoint.com/c/ELyicgMGjC1

Bonjour Papou,

Merci pour cette nouvelle version.

Je regarderai çela à tête reposée car pas le temps ce jour !

Joyeux Noël et au plaisir.

Eddy

paritec a écrit :

Bonjour Eddyeddy patrick le forum

Voilà avec les deux dernières colonnes

a+

Papou

https://www.cjoint.com/c/ELyicgMGjC1

Bonjour Papou, bonjour Patrick, bonjour le forum,

Super impeccable Papou cette nouvelle version.

L'onglet "Menu" est ce que je souhaitait.

Seul petit bémol, les données fusionnées des colonnes f et g ne sont pas l'une en dessous de l'autre !

Sinon, grand merci car c'est vraiment super et

Ré bonjour Edyeddy le forum

En fait tu ne sais pas vraiment ce que tu veux!!!

Tu veux fusionner je suppose pour raccourcir le fichier mais tu veux les informations les unes en dessous des autres???

Ce qui aura pour conséquence de conserver le même nombre de lignes!!!!!

C'est cela que tu veux??

Si oui aucun problème pour moi je le ferai

A plus

Papou

paritec a écrit :

En fait tu ne sais pas vraiment ce que tu veux!!!

Je pense aussi ou alors des explications incomplètes

P.

Bonsoir Patrick le forum

oui c'est pas que l'on comprend rien, mais il veut fusionner et en même temps, il veut conserver le même nombre de ligne???

Ou alors sa seule inquiétude était simplement de faire les totaux des colonnes prix total et nombre de pièces?

mais bon peut-être va t'il nous expliquer cela en détails !!!!

on peut lui faire ce qu'il veut encore faut-il comprendre ce qu'il veut.

bonne soirée et bon Week-end

Papou

Bonsoir à tous,

Concaténer dans une seule cellule, tu vas vite atteindre les limites de ton écran

Test sur une seule feuille.

Option Explicit

Sub test()
Dim a, i As Long, j As Long, n As Long
    a = Sheets("Liste Art 2009").Cells(1).CurrentRegion.Value
    n = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1: .Item(a(i, 1)) = n
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            Else
                a(.Item(a(i, 1)), 3) = a(.Item(a(i, 1)), 3) + a(i, 3)
                a(.Item(a(i, 1)), 5) = a(.Item(a(i, 1)), 5) + a(i, 5)
                a(.Item(a(i, 1)), 6) = a(.Item(a(i, 1)), 6) & vbLf & a(i, 6)
                a(.Item(a(i, 1)), 7) = a(.Item(a(i, 1)), 7) & vbLf & a(i, 7)
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets.Add().Cells(1).Resize(n, UBound(a, 2))
        .Value = a
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        .VerticalAlignment = xlTop
        With .Rows(1)
            .Interior.ColorIndex = 6
            .BorderAround Weight:=xlThin
            .VerticalAlignment = xlCenter
        End With
        .Columns.AutoFit
        .Rows.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

klin89

paritec a écrit :

Ré bonjour Edyeddy le forum

En fait tu ne sais pas vraiment ce que tu veux!!!

Tu veux fusionner je suppose pour raccourcir le fichier mais tu veux les informations les unes en dessous des autres???

Ce qui aura pour conséquence de conserver le même nombre de lignes!!!!!

C'est cela que tu veux??

Si oui aucun problème pour moi je le ferai

A plus

Papou

Bonsoir Papou, Bonsoir Patrick,

Ce n'est pas le fait que je ne sais pas ce que je veux car dans un précédent message j'avais insérer une image de ce que j'aimerai obtenir ! Voir lien https://forum.excel-pratique.com/download/file.php?id=110427&mode=view

En tout cas, merci beaucoup pour le travail.

Eddy


Klin89 a écrit :

Bonsoir à tous,

Concaténer dans une seule cellule, tu vas vite atteindre les limites de ton écran

Test sur une seule feuille.

Option Explicit

Sub test()
Dim a, i As Long, j As Long, n As Long
    a = Sheets("Liste Art 2009").Cells(1).CurrentRegion.Value
    n = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1: .Item(a(i, 1)) = n
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
            Else
                a(.Item(a(i, 1)), 3) = a(.Item(a(i, 1)), 3) + a(i, 3)
                a(.Item(a(i, 1)), 5) = a(.Item(a(i, 1)), 5) + a(i, 5)
                a(.Item(a(i, 1)), 6) = a(.Item(a(i, 1)), 6) & vbLf & a(i, 6)
                a(.Item(a(i, 1)), 7) = a(.Item(a(i, 1)), 7) & vbLf & a(i, 7)
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets.Add().Cells(1).Resize(n, UBound(a, 2))
        .Value = a
        .Borders(xlInsideVertical).Weight = xlThin
        .BorderAround Weight:=xlThin
        .VerticalAlignment = xlTop
        With .Rows(1)
            .Interior.ColorIndex = 6
            .BorderAround Weight:=xlThin
            .VerticalAlignment = xlCenter
        End With
        .Columns.AutoFit
        .Rows.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

klin89

Bonsoir klin89,

Merci d'apporter ton aide sur à ma demande mais que dois je faire avec le code ci-dessus ?

Eddy

Re EddyEddy,

Dans ton cas, la concaténation de tes données dans les cellules des colonnes F et G n'est pas une bonne idée.

Tu vas vite atteindre les limites de tes cellules et tronquer leur contenu.

Perso, je verrai la disposition sur plusieurs lignes.

Sinon, faut-il parcourir plusieurs feuilles ?

A tester :

Option Explicit

Sub test()
Dim a, i As Long, w(), n As Long, x As Long, y
    a = Sheets("Liste Art 2009").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To 7, 1 To 1)
                w(1, 1) = a(i, 1): w(2, 1) = a(i, 2): w(3, 1) = a(i, 3)
                w(4, 1) = CDbl(a(i, 4)): w(5, 1) = CDbl(a(i, 5)): w(6, 1) = a(i, 6)
                w(7, 1) = a(i, 7)
                .Item(a(i, 1)) = w
            Else
                w = .Item(a(i, 1))
                ReDim Preserve w(1 To 7, 1 To UBound(w, 2) + 1)
                x = UBound(w, 2)
                w(3, 1) = w(3, 1) + a(i, 3): w(5, 1) = w(5, 1) + CDbl(a(i, 5))
                w(6, x) = a(i, 6): w(7, x) = a(i, 7)
                .Item(a(i, 1)) = w
            End If
        Next
        y = .items
    End With
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Restitution").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    With Sheets.Add().Cells(1)
        .Parent.Name = "Restitution"
        With .Resize(, UBound(a, 2))
            '.EntireColumn.Clear
            .Value = a
        End With
        With .Offset(1)
            For i = 0 To UBound(y)
                With .Offset(n).Resize(UBound(y(i), 2), UBound(y(i), 1))
                    .Value = Application.Transpose(y(i))
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                End With
                n = n + UBound(y(i), 2)
            Next
        End With
        With .CurrentRegion
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .Rows.RowHeight = 16
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .Interior.ColorIndex = 6
                .HorizontalAlignment = xlCenter
                .RowHeight = 27
            End With
            .Columns("d:e").NumberFormat = Array("#,##0.00 €", "#,##0.00 €")
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Edit : bonjour paritec, patrick1957

klin89

Klin89 a écrit :

Re EddyEddy,

Dans ton cas, la concaténation de tes données dans les cellules des colonnes F et G n'est pas une bonne idée.

Tu vas vite atteindre les limites de tes cellules et tronquer leur contenu.

Perso, je verrai la disposition sur plusieurs lignes.

Sinon, faut-il parcourir plusieurs feuilles ?

A tester :

Option Explicit

Sub test()
Dim a, i As Long, w(), n As Long, x As Long, y
    a = Sheets("Liste Art 2009").Cells(1).CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                ReDim w(1 To 7, 1 To 1)
                w(1, 1) = a(i, 1): w(2, 1) = a(i, 2): w(3, 1) = a(i, 3)
                w(4, 1) = CDbl(a(i, 4)): w(5, 1) = CDbl(a(i, 5)): w(6, 1) = a(i, 6)
                w(7, 1) = a(i, 7)
                .Item(a(i, 1)) = w
            Else
                w = .Item(a(i, 1))
                ReDim Preserve w(1 To 7, 1 To UBound(w, 2) + 1)
                x = UBound(w, 2)
                w(3, 1) = w(3, 1) + a(i, 3): w(5, 1) = w(5, 1) + CDbl(a(i, 5))
                w(6, x) = a(i, 6): w(7, x) = a(i, 7)
                .Item(a(i, 1)) = w
            End If
        Next
        y = .items
    End With
    Application.ScreenUpdating = False
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Restitution").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
    With Sheets.Add().Cells(1)
        .Parent.Name = "Restitution"
        With .Resize(, UBound(a, 2))
            '.EntireColumn.Clear
            .Value = a
        End With
        With .Offset(1)
            For i = 0 To UBound(y)
                With .Offset(n).Resize(UBound(y(i), 2), UBound(y(i), 1))
                    .Value = Application.Transpose(y(i))
                    .BorderAround Weight:=xlThin
                    .Borders(xlInsideVertical).Weight = xlThin
                End With
                n = n + UBound(y(i), 2)
            Next
        End With
        With .CurrentRegion
            .Font.Size = 10
            .VerticalAlignment = xlCenter
            .Rows.RowHeight = 16
            With .Rows(1)
                .BorderAround Weight:=xlThin
                .Borders(xlInsideVertical).Weight = xlThin
                .Interior.ColorIndex = 6
                .HorizontalAlignment = xlCenter
                .RowHeight = 27
            End With
            .Columns("d:e").NumberFormat = Array("#,##0.00 €", "#,##0.00 €")
            .Columns.AutoFit
        End With
    End With
    Application.ScreenUpdating = True
End Sub

Edit : bonjour paritec, patrick1957

klin89

Bonjour klin89

Que veux tu dire par "faut-il parcourir plusieurs feuilles" ?

Et le code ci-dessus, à quoi sert-il ?

Merci, Eddy

Re Bonsoir à Tous le forum

Voilà Eddyeddy le résultat comme tu le souhaites

a+

Papou

https://www.cjoint.com/c/ELCrGniI6GW

Re EddyEddy,

Evite de rééditer mes codes, cela encombre le fil 8)

La même solution que Paritec, sauf que je ne fusionne pas les cellules des colonnes F et G

Soit une feuille distincte créée pour chaque feuille traitée.

Option Explicit

Sub test()
Dim a, i As Long, w(), n As Long, x As Long, s, y, sn As String
    Application.ScreenUpdating = False
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        'On parcourt les feuilles à traiter (à compléter)
        For Each s In Array("Liste Art 2009", "Liste Art 2010")
            a = Sheets(s).Cells(1).CurrentRegion.Value
            For i = 2 To UBound(a, 1)
                If Not .exists(a(i, 1)) Then
                    ReDim w(1 To 7, 1 To 1)
                    w(1, 1) = a(i, 1): w(2, 1) = a(i, 2): w(3, 1) = a(i, 3)
                    w(4, 1) = CDbl(a(i, 4)): w(5, 1) = CDbl(a(i, 5)): w(6, 1) = a(i, 6)
                    w(7, 1) = a(i, 7)
                    .Item(a(i, 1)) = w
                Else
                    w = .Item(a(i, 1))
                    ReDim Preserve w(1 To 7, 1 To UBound(w, 2) + 1)
                    x = UBound(w, 2)
                    w(3, 1) = w(3, 1) + a(i, 3): w(5, 1) = w(5, 1) + CDbl(a(i, 5))
                    w(6, x) = a(i, 6): w(7, x) = a(i, 7)
                    .Item(a(i, 1)) = w
                End If
            Next
            y = .items
            On Error Resume Next
            Application.DisplayAlerts = False
            sn = Right(s, 8)
            Sheets(sn).Delete
            On Error GoTo 0
            Application.DisplayAlerts = True
            'On crée une feuille distincte pour chaque feuille traitée
            Sheets.Add().Name = sn
            With Sheets(sn).Cells(1)
                n = 0
                With .Resize(, UBound(a, 2))
                    .Value = a
                End With
                With .Offset(1)
                    For i = 0 To UBound(y)
                        With .Offset(n).Resize(UBound(y(i), 2), UBound(y(i), 1))
                            .Value = Application.Transpose(y(i))
                            .BorderAround Weight:=xlThin
                            .Borders(xlInsideVertical).Weight = xlThin
                        End With
                        n = n + UBound(y(i), 2)
                    Next
                End With
                With .CurrentRegion
                    .Font.Size = 10
                    .VerticalAlignment = xlCenter
                    .Rows.RowHeight = 16
                    With .Rows(1)
                        .BorderAround Weight:=xlThin
                        .Borders(xlInsideVertical).Weight = xlThin
                        .Interior.ColorIndex = 6
                        .HorizontalAlignment = xlCenter
                        .RowHeight = 27
                    End With
                    .Columns("d:e").NumberFormat = Array("#,##0.00 €", "#,##0.00 €")
                    .Columns.AutoFit
                End With
            End With
            .RemoveAll
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Nouvelle question : faut-il traiter toutes les feuilles et résumer le tout sur une seule feuille ?

klin89

paritec a écrit :

Re Bonsoir à Tous le forum

Voilà Eddyeddy le résultat comme tu le souhaites

a+

Papou

https://www.cjoint.com/c/ELCrGniI6GW

Bonsoir Papou,

Mes meilleurs vœux pour cette nouvelle année.

L'exemple N°4 est comme je l'espérai et grand merci.

@+

Eddy


Bonsoir Patrick et klin89,

Mes meilleurs vœux pour cette nouvelle année à vous aussi.

Merci de m'avoir également apporter votre aide sur ce sujet.

La dernière proposition de Papou (paritec) me convenait parfaitement car c'est ce que je désirai.

@+

Eddy

Rechercher des sujets similaires à "fusionner identiques"