XL 2016 Fusion de lignes sur Excel

[Antoren]

Bonjour a tous,

Je suis peu habitue a excel et je dois simplifier une base de données. Je cherche a fusionner des lignes tout en gardant l’intégralité des données contenues mais j'ai des conditions a appliquer a cette fusion.
Je veux seulement fusionner ensemble les lignes ayant la même numéro d'identification qui est inscrit sur la première colonne. Les données fusionnées des lignes inférieures devraient s'ajouter en bout de ligne en générant de nouvelles colonnes. La base de donnée comportent plus de 20 000 lignes je cherche donc quelque-chose qui serait automatique.
Jusqu’à maintenant j'ai simplement réussi a fusionner les lignes ensembles manuellement et en les ajoutant dans les mêmes colonnes sans en générer de nouvelles.
J'ai joint a mon message un échantillon de la base de données.

Un exemple pour expliciter ce que je souhaite faire :

Initial:
A 23 rouge T3
B 24 vert T3
B 27 jaune T2

Changement:
A 23 rouge T3
B 24 vert T3 27 jaune T2

Merci pour votre aide

 

[job75]

Bonjour Antoren, bienvenue sur XLD,

Je n'ai rien compris ! Il faudrait ajouter une feuille dans le fichier montrant le résultat attendu.

A+

 

[Antoren]

Bonjour,

Ci joint le fichier modifié comme je le souhaiterais

Merci pour votre aide

 

[job75]

Voyez le fichier joint et cette macro :

Sub RegrouperLignes()
Dim ncol%, F As Worksheet, P As Range, nlig&, i&, n&, k&, j&
ncol = 7 'nombre de colonnes à copier
Set F = ActiveSheet
Application.ScreenUpdating = False
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
Set P = F.Range("A1", F.Range("A" & F.Rows.Count).End(xlUp))
nlig = P.Rows.Count
For i = 1 To nlig
    n = Application.CountIf(P, P(i))
    If n > 1 Then
        k = 1
        For j = i + 1 To nlig
            If P(j) = P(i) Then
                P(j, 2).Resize(, ncol).Copy P(i, k * ncol + 2)
                P(j) = "" 'repérage
                k = k + 1
                If k = n Then Exit For
            End If
        Next j
    End If
Next i
On Error Resume Next 'si aucune SpecialCell
P.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Nota 1 : j'ai supprimé les formules en colonne H car elles n'étaient pas acceptées sur Excel 2013.

Nota 2 : l'exécution prendra du temps s'il y a beaucoup de lignes, dans ce cas il vaudra mieux utiliser des tableaux VBA.

Bonne nuit.

 

[job75]

Bonjour Antoren, le forum,

Avec des tableaux VBA c'est compliqué mais ce sera très rapide sur un grand tableau :

Sub RegrouperLignes()
Dim ncol%, F As Worksheet, P As Range, tablo, d As Object, i&, ub%, resu(), s, lig&, col%, j%, n&, x$, k%
ncol = 8 'nombre de colonnes
Set F = ActiveSheet
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
Set P = F.Range("A1", F.Range("A" & F.Rows.Count).End(xlUp)).Resize(, ncol)
tablo = P.FormulaR1C1
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
    d(tablo(i, 1)) = d(tablo(i, 1)) + 1 'comptage
Next
If d.Count Then
    ub = Application.Max(d.items) * (ncol - 1) + 1
    ReDim resu(1 To d.Count, 1 To ub)
    d.RemoveAll
    For i = 1 To UBound(tablo)
        If d.exists(tablo(i, 1)) Then
            s = Split(d(tablo(i, 1)))
            lig = s(0): col = s(1)
            d(tablo(i, 1)) = lig & " " & col + ncol - 1
            For j = 2 To ncol
                If tablo(i, j) = "" Then tablo(i, j) = " "
                resu(lig, col + j - 2) = tablo(i, j)
            Next j
        Else
            n = n + 1
            d(tablo(i, 1)) = n & " " & ncol + 1 'mémorise la ligne et la colonne
            For j = 1 To ncol
                If tablo(i, j) = "" Then tablo(i, j) = " "
                resu(n, j) = tablo(i, j)
            Next j
        End If
    Next i
    '---mise en forme, MFC et restitution---
    Application.ScreenUpdating = False
    F.Cells.FormatConditions.Delete
    For j = 5 To ub Step ncol - 1
        P(1, j).Resize(n).NumberFormat = "dd/mm/yyyy"
    Next j
    F.[A1] = "=MOD(ROW(),2)": x = Mid(F.[A1].FormulaLocal, 2) 'pour toutes versions
    For j = ncol + 1 To ub Step ncol - 1
        k = k + 1
        With P(1, j).Resize(n, ncol - 1)
            .FormatConditions.Add xlExpression, Formula1:="=(" & .Cells(1).Address(0, 0) & "<>""""" & IIf(k Mod 2, ")*(" & x & "=0)", ")*" & x)
            .FormatConditions(1).Borders.Weight = xlThin
            .FormatConditions(1).Interior.Color = 15917529 'bleu
            .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(1).Address(0, 0) & "<>"""""
            .FormatConditions(2).Borders.Weight = xlThin
        End With
    Next j
    P.Resize(n, ub) = resu
End If
P.Offset(n).Resize(F.Rows.Count - n - P.Row + 1, ub).Delete xlUp 'RAZ en dessous
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Fichier (2), notez que j'ai remis des formules en colonne H, acceptées sur toute version Excel.

A+

 

[Antoren]

Merci
J'ai utilisé la premier code et cela a parfaitement fonctionné. Mais effectivement Excel vient à peine de finir, ça a pris environ 3 heures pour faire toutes les fusions de lignes.
Quand vous parlez de tableau VBA, c'est un changement dans la façon de coder. Vous recréez un tableau avec VBA ? Car je devrais sans doute manipuler encore ma base de données et je viens de réaliser le temps que prenait la réalisation d'un changement.

Merci encore pour votre aide

 

[job75]

J'ai corrigé la macro du fichier (2) : il faut mémoriser dans l'item du Dictionary non seulement la ligne mais aussi la colonne.

Pour tester j'ai recopié le tableau A1:H19 sur 1900 lignes et j'ai eu une surprise :

- macro du fichier (1) => 21 secondes

- macro du fichier (2) => 19 secondes dont 17 secondes pour la création des MFC, le gain de temps est peu important.

Le gain sera bien plus significatif s'il y a peu de colonnes ajoutées.

Bonne nuit.

 

[job75]

Bonjour Antoren, mapomme, le forum,

La création des MFC avec une boucle prenait trop de temps, j'ai modifié sans boucle :

Sub RegrouperLignes()
Dim ncol%, F As Worksheet, P As Range, tablo, d As Object, i&, ub%, resu(), s, lig&, col%, j%, n&, x$
ncol = 8 'nombre de colonnes
Set F = ActiveSheet
If F.FilterMode Then F.ShowAllData 'si la feuille est filtrée
Set P = F.Range("A1", F.Range("A" & F.Rows.Count).End(xlUp)).Resize(, ncol)
tablo = P.FormulaR1C1
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(tablo)
    d(tablo(i, 1)) = d(tablo(i, 1)) + 1 'comptage
Next
If d.Count Then
    ub = Application.Max(d.items) * (ncol - 1) + 1
    If ub = ncol Then n = d.Count: GoTo 1
    ReDim resu(1 To d.Count, 1 To ub)
    d.RemoveAll
    For i = 1 To UBound(tablo)
        If d.exists(tablo(i, 1)) Then
            s = Split(d(tablo(i, 1)))
            lig = s(0): col = s(1)
            d(tablo(i, 1)) = lig & " " & col + ncol - 1
            For j = 2 To ncol
                If tablo(i, j) = "" Then tablo(i, j) = " "
                resu(lig, col + j - 2) = tablo(i, j)
            Next j
        Else
            n = n + 1
            d(tablo(i, 1)) = n & " " & ncol + 1 'mémorise la ligne et la colonne
            For j = 1 To ncol
                If tablo(i, j) = "" Then tablo(i, j) = " "
                resu(n, j) = tablo(i, j)
            Next j
        End If
    Next i
    '---mise en forme, MFC et restitution---
    Application.ScreenUpdating = False
    F.Cells.FormatConditions.Delete
    For j = 5 To ub Step ncol - 1
        P(1, j).Resize(n).NumberFormat = "dd/mm/yyyy"
    Next j
    F.[A1] = "=IF(MOD(ROW(),2),MOD(Int((COLUMN()-Pas-2)/Pas),2),MOD(Int((COLUMN()-Pas-2)/Pas),2)=0)" 'pour toutes versions
    x = Mid(F.[A1].FormulaLocal, 2)
    ThisWorkbook.Names.Add "Pas", ncol - 1 'nom défini
    With P(1, ncol + 1).Resize(n, ub - ncol)
        .FormatConditions.Add xlExpression, Formula1:="=(" & .Cells(1).Address(0, 0) & "<>""""" & ")*" & x
        .FormatConditions(1).Interior.Color = 15917529 'bleu
        .FormatConditions(1).Borders.Weight = xlThin
        .FormatConditions.Add xlExpression, Formula1:="=" & .Cells(1).Address(0, 0) & "<>"""""
        .FormatConditions(2).Borders.Weight = xlThin
    End With
    P.Resize(n, ub) = resu
End If
1 P.Offset(n).Resize(F.Rows.Count - n - P.Row + 1, ub).Delete xlUp 'RAZ en dessous
With F.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Fichiers (3), sur 1900 lignes la macro s'exécute chez moi en 1,7 seconde.

A+