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 |
Partager