Discussion :

[Frs95]

Bonjour à tous,

Je souhaiterai créer une macro me servant à copier les données d'une feuille selon un critère défini vers une autre feuille.

Exemple :

Feuille 1 :

          A            B            C                  D                 E
1    N° Client      Nom Clt      Code Postal      Type Article    Quantité Article
2         1         Dupont          95000           Marteau             2
3         1         Dupont          95000            Ciseau             1
4         1         Dupont          95000           Marteau             1
5         2         Martin          60000            Ciseau             4
6         2         Martin          60000           Marteau              1
7         3         Bernard         75000           Marteau              1
8

Résultat attendus dans la feuille 2 :

         A            B              C               D                 E                 F                 G                 H                 I
1    N° Client      Nom Clt      Code Postal     Type Article 1   Qtés Article 1    Type Article 2    Qtés Article 2    Type Article 3    Qtés Article 3
2         1         Dupont         95000             Marteau            2                Ciseau             1              Marteau               1
3         2         Martin         60000              Ciseau            4               Marteau             1
4         3        Bernard         75000             Marteau            1

Merci de votre aide

[Invité]

Bonjour,

Une solution avec ce code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
Option Explicit
 
Public ListeReferencesClient As New Collection
 
Sub CopierEtTransposerChaqueCommandeSurUneLigne()
 
Dim ShSource As Worksheet
Dim LigneDeTitreSource As Long
Dim DerniereLigneSource As Long
Dim AireSource As Range
Dim CelluleSource As Range
Dim CompteurSource As Long
 
 
Dim ShCible As Worksheet
Dim LigneDeTitreCible As Long
Dim LigneEnCoursCible As Long
Dim ColonneEnCoursCible As Long
Dim DerniereColonneCible As Long
Dim AireCible As Range
Dim CompteurCible As Long
 
    Set ShSource = Sheets("Feuil1") ' A adapter
    LigneDeTitreSource = 1          ' A adapter
    Set ShCible = Sheets("Feuil2")  ' A adapter
    LigneDeTitreCible = 1           ' A adapter
 
    With ShCible
       .Cells.ClearContents
    End With
 
    With ShSource
         DerniereLigneSource = .Cells(.Rows.Count, 1).End(xlUp).Row
         If DerniereLigneSource <= LigneDeTitreSource Then
                Set ShSource = Nothing
                Set ShCible = Nothing
                Exit Sub
         End If
         Set AireSource = .Range(.Cells(LigneDeTitreSource + 1, 1), .Cells(DerniereLigneSource, 1))
    End With
 
    ListerLesReferencesClientSansDoublon AireSource
 
    If ListeReferencesClient.Count > 0 Then
 
        LigneEnCoursCible = LigneDeTitreCible + 1
        For CompteurSource = 1 To ListeReferencesClient.Count
 
                ColonneEnCoursCible = 4
                For Each CelluleSource In AireSource
                    If CelluleSource = ListeReferencesClient(CompteurSource) Then
                            With ShCible
                                 .Cells(LigneEnCoursCible, 1) = CelluleSource                                    ' Référence client
                                 .Cells(LigneEnCoursCible, 2) = CelluleSource.Offset(0, 1)                       ' Nom du client
                                 .Cells(LigneEnCoursCible, 3) = "'" & CelluleSource.Offset(0, 2)                 ' Code postal
                                 .Cells(LigneEnCoursCible, ColonneEnCoursCible) = CelluleSource.Offset(0, 3)     ' Article
                                 .Cells(LigneEnCoursCible, ColonneEnCoursCible + 1) = CelluleSource.Offset(0, 4) ' Quantité
                                  ColonneEnCoursCible = ColonneEnCoursCible + 2
                            End With
                    End If
 
                Next CelluleSource
                LigneEnCoursCible = LigneEnCoursCible + 1
        Next CompteurSource
 
        With ShCible
 
             .Range(.Cells(LigneDeTitreCible, 1), .Cells(LigneDeTitreCible + 2)).Value = Array("Numéro client", "Nom du Client", "Code postal")
             DerniereColonneCible = .UsedRange.Columns.Count
             CompteurCible = 1
             For ColonneEnCoursCible = 4 To DerniereColonneCible Step 2
 
                .Cells(LigneDeTitreCible, ColonneEnCoursCible).Value = "Article " & CompteurCible
                .Cells(LigneDeTitreCible, ColonneEnCoursCible + 1).Value = "Quantité " & CompteurCible
                 CompteurCible = CompteurCible + 1
 
             Next ColonneEnCoursCible
 
        End With
 
    End If
 
End Sub
 
 
 
Sub ListerLesReferencesClientSansDoublon(ByVal Plage As Range)
 
 Dim CelluleReferenceClient As Range
        On Error Resume Next
        For Each CelluleReferenceClient In Plage
            If Not IsError(CelluleReferenceClient) Then
               If CelluleReferenceClient <> "" Then ListeReferencesClient.Add CelluleReferenceClient.Value, CStr(CelluleReferenceClient.Value)
            End If
        Next CelluleReferenceClient
        On Error GoTo 0
 
 End Sub

Cordialement.