Transposer selon critéres

[heritias]

Bonjour ,
Dans l'onglet "origine" j'ai plusieurs lignes avec le même numéro de facture mais des articles différents .
Dans l'onglet "Synthèse" je souhaite retrouver une ligne par numéro facture et tous les articles mis bout à bout.
ex :
N° de facture Référence article Libelle article
100 a Libellé a
100 b Libellé b
100 c Libellé c
105 a Libellé a
105 d Libellé d
108 e Libellé e
107 a Libellé a
107 e Libellé e
107 f Libellé f
107 g Libellé g
Le résultat souhaité :
100 a Libellé a b Libellé b c Libellé c
105 a Libellé a d Libellé d
108 e Libellé e
107 a Libellé a e Libellé e f Libellé f g Libellé g

Le recherchev ne me trouve que la 1ere valeur . Le fichier en pièces jointe pour plus de lisibilité .

Merci par avance de vos retours .Bonne soirée .

 

[kingfadhel]

Bonsoir, le forum
@heritias

à toi

Sub heritias()
lig = Sheets("Origine").Cells(65000, 1).End(xlUp).Row
For i = 2 To lig
    With Sheets("origine")
        a = .Cells(i, 1)
        a2 = .Cells(i - 1, 1)
        b = .Cells(i, 2)
        c = .Cells(i, 3)
    End With
    If a <> a2 Then
    With Sheets("Synthése")
    lig1 = .Cells(65000, 1).End(xlUp).Row + 1
    .Cells(lig1, 1) = a
    .Cells(lig1, 2) = b
    .Cells(lig1, 3) = c
    End With
    Else
    With Sheets("Synthése")
    lig2 = .Cells(65000, 1).End(xlUp).Row '+ 1
    col1 = .Cells(lig2, 320).End(xlToLeft).Column + 1
        .Cells(lig2, col1) = b
        .Cells(lig2, col1 + 1) = c
    End With
    End If
Next
End Sub

 

[zebanx]

Bonsoir heritias, kingfadhel

@kingfadhel
Joli code -). Merci.
Dans l'approche, ça aurait peut-être été préférable de faire un clear-contents du tableau de résultat (sinon les données s'inscrivent en-dessous après chaque enregistrement) et peut-être sur le début / fin de code l'insertion d'un Application.Calculation = xlCalculationManual / Application.Calculation = xlCalculationManual si la plage est assez longue, qu'en penses-tu ?

Bonne soirée
zebanx

 

[kingfadhel]

Bonjour, le forum, le fil.

@zebanx , toutes modifications, simplification, amélioration du code est préférable.

Sub heritias()
    With Sheets("Synthése")
        .Columns("D:AL").Delete Shift:=xlToLeft
        .Rows("2:3000").Delete Shift:=xlUp
    End With
lig = Sheets("Origine").Cells(65000, 1).End(xlUp).Row
For i = 2 To lig
    With Sheets("origine")
        a = .Cells(i, 1)
        a2 = .Cells(i - 1, 1)
        b = .Cells(i, 2)
        c = .Cells(i, 3)
        d = "Référence article"
        e = "Libelle article"
    End With
    If a <> a2 Then
    With Sheets("Synthése")
    lig1 = .Cells(65000, 1).End(xlUp).Row + 1
    .Cells(lig1, 1) = a
    .Cells(lig1, 2) = b
    .Cells(lig1, 3) = c
    End With
    Else
    With Sheets("Synthése")
    lig2 = .Cells(65000, 1).End(xlUp).Row '+ 1
    col1 = .Cells(lig2, 320).End(xlToLeft).Column + 1
        .Cells(lig2, col1) = b
        .Cells(lig2, col1 + 1) = c
        .Cells(1, col1) = d
        .Cells(1, col1 + 1) = e
    End With
    End If
Next
End Sub

 

[job75]

Bonjour heritias, kingfadhel, zebanx,

@zebanx , toutes modifications, simplification, amélioration du code est préférable.

Alors pas de VBA du tout, formule matricielle en Synthèse!B2 :

=SIERREUR(DECALER(N°;PETITE.VALEUR(SI(N°=$A2;LIGNE(N°));1+ENT((COLONNES($B2:B2)-1)/2))-1;2-MOD(COLONNES($B2:B2);2);1);"")

A valider par Ctrl+Maj+Entrée et à tirer vers le bas et à droite.

Fichier joint.

A+