Déplacer des cellules vers des colonnes si doublons VBA

Bonsoir tout le monde,

Vous trouverez en pj, une explication de mon problème

l'idée est la suivante, j'ai un fichier avec plusieurs milier de ligne, et l'objectif est de remettre les familles sous formes de collones cote à cote

si quelqu'un peu m'aider, ce serait très sympas

Cordialement

Edouard 002

Bonjour,

Ci-joint un début de réponse à adapter (Ctrl+q pour lancer la procédure).

A te relire. Cdlt

Option Explicit
Public Sub Traitement()
Dim sH_1 As Worksheet, sH_2 As Worksheet
Dim derLigne As Integer, derColonne As Byte
Dim i As Integer, j As Integer
Dim Plg As Range

    Application.ScreenUpdating = False

    Set sH_1 = Worksheets("Données brutes")
    Set sH_2 = Worksheets("Données traitées")

    With sH_1
        derLigne = .Range("A" & Rows.Count).End(xlUp).Row
        j = 1
        For i = 2 To derLigne Step 1
            If .Cells(i, 1) <> .Cells(i - 1, 1) Then
                Set Plg = .Range(Cells(i, 1), Cells(i, 5))
                j = j + 1
                Plg.Copy Destination:=sH_2.Cells(j, 1)
            Else
                derColonne = sH_2.Cells(j, Cells.Columns.Count).End(xlToLeft).Column
                Set Plg = .Range(Cells(i, 1), Cells(i, 5))
                Plg.Copy Destination:=sH_2.Cells(j, derColonne + 1)
            End If
        Next i
    End With

    With sH_2
        derColonne = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
        For i = 6 To derColonne Step 4
            .Columns(i).Delete Shift:=xlToLeft
        Next i
        derColonne = .UsedRange.SpecialCells(xlCellTypeLastCell).Column
        For i = 4 To derColonne Step 3
            .Columns(i).Delete Shift:=xlToLeft
        Next i
    End With
End Sub