Macro fusion de cellules

[raigo]

Bonjour à tous,

Je dois fusionner certaines cellules d'un document Excel pour mon projet. Cependant je n'ai aucunes notions de ce langage.
Mon document est une base de données d'articles où chaque ligne représente un article, et chaque colonne une de ses caractéristiques.
Je vous expose le principe en simplifié :
Parmi ses caractéristiques il y a son NOM, sa COULEUR et sa TAILLE. La TAILLE peut être en fonction du type d'article : 'S, M, L' ou '38, 40, 42'.
Je voudrais supprimer tous les doublons dont le NOM et la COULEUR sont les mêmes, tout en gardant dans la même cellule les différentes TAILLE.

Quelques précisions :
NOM et COULEUR contiennent des chiffres, des lettres et des caractères spéciaux
COULEUR ne contient dans le fichier d'origine une seule valeur : une lettre ou un nombre

SI les valeurs des colonnes NOM et COULEUR de la ligne sont égales aux valeurs des mêmes colonnes sur une autre ligne
ALORS SI les valeurs de la colonne TAILLE sont égales supprimer le doublon
SINON concaténer les valeurs contenues dans TAILLE (avec une fonction de tri alphabétique ou numérique croissant serait le top) puis supprimer l'autre ligne

Merci beaucoup d'avance !

 

[klin89]

Re : Macro fusion de cellules

Bonsoir raigo

Pour déterminer les doublons, sur quelle(s) colonne(s) se base t-on, il n'y a pas d'en-têtes ?
A tester, je me suis basé sur la 1ère colonne.

Option Explicit

Sub test()
Dim a, i As Long, j As Byte, n As Long
    a = Sheets(1).Range("a2").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 1 To UBound(a, 1)
            If Not .exists(a(i, 1)) Then
                n = n + 1
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
                .Item(a(i, 1)) = n
            Else
                a(.Item(a(i, 1)), 6) = a(.Item(a(i, 1)), 6) & _
                                       " " & a(i, 6)
            End If
        Next
    End With
    'restitution en Feuil2
    With Sheets(2).Range("a1")
        .CurrentRegion.Clear
        .Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Columns.AutoFit
            .Rows.RowHeight = 19
        End With
        .Parent.Activate
    End With
End Sub

klin89

 

[raigo]

Re : Macro fusion de cellules

Bonjour klin89,

Merci pour ta réponse, le script fonctionne et c'est presque parfait !
Je me base juste sur deux colonnes et non pas que la première, j'ai un code couleur dans qui différencie les articles qui ont le même modèle.
Pou répondre à ta question oui j'ai bien des en têtes donc c'est tout à fait judicieux de commencer à partir de la seconde ligne.
Si tu as encore du temps pour me fournir une réponse en prenant ces informations en compte je t'en serait vraiment reconnaissant !

Merci à tous !

 

[klin89]

Re : Macro fusion de cellules

Re raigo,

A tester :

Sub test()
Dim a, i As Long, j As Byte, n As Long, txt As String
    Application.ScreenUpdating = False
    'La feuille à traiter en 1ère position dans le classeur
    'Les données à partir de A1
    a = Sheets(1).Range("a1").CurrentRegion.Value
    'Avec en-têtes
    n = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            'Détermine la clé sur les 2 premiéres colonnes
            txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
            If Not .exists(txt) Then
                n = n + 1
                For j = 1 To UBound(a, 2)
                    a(n, j) = a(i, j)
                Next
                .Item(txt) = n
            Else
                a(.Item(txt), 6) = a(.Item(txt), 6) & _
                                   " " & a(i, 6)
            End If
        Next
    End With
    'Création d'une nouvelle feuille et restitution
    With Sheets.Add.Cells(1)
        .CurrentRegion.Clear
        .Resize(n, UBound(a, 2)).Value = a
        With .CurrentRegion
            .Font.Name = "calibri"
            .Font.Size = 10
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .Rows.RowHeight = 19
            With .Rows(1)
                .Interior.ColorIndex = 42
                .BorderAround Weight:=xlThin
            End With
            .Columns.AutoFit
        End With
        .Parent.Activate
    End With
    Application.ScreenUpdating = True
End Sub

klin89

 

[raigo]

Re : Macro fusion de cellules

Super merci klin89 !!

C'est exactement ce qu'il me fallait, j'ai juste remplacé la ligne
txt = Join(Array(a(i, 1), a(i, 2)), Chr(2))
par
txt = Join(Array(a(i, 1), a(i, 4)), Chr(2))
pour l'adapter à mon document où j'avais besoin des clés sur les colonnes 1 et 4.

Merci encore pour la rapidité et la qualité de ta réponse