Transposer selon critéres

heritias · 10 Janvier 2018

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 · 10 Janvier 2018

Bonsoir, le forum
@heritias

à toi

VB:

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 · 10 Janvier 2018

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 · 11 Janvier 2018

Bonjour, le forum, le fil.

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

VB:

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 · 13 Janvier 2018

Bonjour heritias, kingfadhel, zebanx,

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

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

Code:

=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+

Transposer selon critéres

heritias

XLDnaute Nouveau

Pièces jointes

kingfadhel

XLDnaute Impliqué

zebanx

XLDnaute Accro

kingfadhel

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Transposer selon critéres

heritias

XLDnaute Nouveau

Pièces jointes

kingfadhel

XLDnaute Impliqué

zebanx

XLDnaute Accro

kingfadhel

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency