XL 2013 Copie de données entre 2 feuilles sous conditions

[ivan27]

Bonjour le forum,

Je vous sollicite car j'ai besoin d'aide pour une copie sous conditions entre 2 feuilles.

J'ai une feuille "origine" dans laquelle je dois prélever des données et une feuille "destination" dans laquelle je vais copier les données prélevées.

Chaque feuille peut contenir plusieurs milliers de lignes.

Les données "origine" doivent être copiées à la suite des données existante dans "destination".

Conditions :

Si dans "origine", colonne A = ABC et colonne D = MON CLIENT alors j'effectue la copie suivante :
colonnes "Origine" vers colonne "Destination"
E vers A
D vers B
J vers C
L vers D

Si dans "origine", colonne A = LAP et colonne D = MON CLIENT alors j'effectue la copie suivante :
colonnes "Origine" vers "Destination"
E vers A
D vers B
J vers E
L vers F

Merci d'avance pour votre aide

Bonne journée à tous

Ivan

 

[joss56]

Bonjour

Un essai en pièce jointe avec le filtre avancé.

Jocelyn

 

[Theze]

Bonjour,

Une piste :

Sub Test()

    Dim Plage As Range
    Dim Cel As Range
    Dim L As Long
  
    'défini la plage sur la colonne A à partir de A2 de la feuille "Origine"
    With Worksheets("Origine")
    
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
  
    End With
      
    For Each Cel In Plage
  
        With Worksheets("Destination")
      
            Select Case Cel.Offset(, 3).Value
          
                Case "MON CLIENT"
              
                    L = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'sur colonne A
                    .Cells(L, 1).Value = Cel.Offset(, 4).Value
                    .Cells(L, 2).Value = Cel.Offset(, 3).Value
                  
                    If Cel.Value = "ABC" Then
                  
                        .Cells(L, 3).Value = Cel.Offset(, 9).Value
                        .Cells(L, 4).Value = Cel.Offset(, 11).Value
                  
                    ElseIf Cel.Value = " LAP" Then
                  
                        .Cells(L, 5).Value = Cel.Offset(, 9).Value
                        .Cells(L, 6).Value = Cel.Offset(, 11).Value
                  
                    End If
                  
            End Select
              
        End With
      
    Next Cel
  
End Sub

 

[Modeste]

Bonjour ivan, joss56, Theze,

Une troisième proposition (avec des tableaux en mémoire):
Ajouter un module standard et y coller ces quelques lignes

Sub transfert()
Set o = Sheets("origine")
Set d = Sheets("destination")
tabloS = o.[A1].CurrentRegion
ReDim tabloD(1 To UBound(tabloS), 1 To 6)
lig = 1
For i = 2 To UBound(tabloS)
    If tabloS(i, 4) = "MON CLIENT" Then
        tabloD(lig, 1) = tabloS(i, 5)
        tabloD(lig, 2) = tabloS(i, 4)
        If tabloS(i, 1) = "ABC" Then
            tabloD(lig, 3) = tabloS(i, 10)
            tabloD(lig, 4) = tabloS(i, 12)
        ElseIf tabloS(i, 1) = "LAP" Then
            tabloD(lig, 5) = tabloS(i, 10)
            tabloD(lig, 6) = tabloS(i, 12)
        End If
        lig = lig + 1
    End If
Next i
derlig = d.Cells(Rows.Count, 1).End(xlUp).Row + 1
d.Cells(derlig, 1).Resize(lig, 6) = tabloD
End Sub

... Je te laisse le soin de vérifier si les résultats sont corrects.
Attention: dans tes consignes, D vers B ne semble pas correspondre au contenu de la feuille destination!?

 

[ivan27]

Re bonjour le forum, joss56, These, Modeste,

Merci beaucoup pour vos propositions.
Modeste, après vérification la consigne D vers B est correcte et tu y réponds parfaitement.
Theze, les consignes J vers E et L vers F ne fonctionnent pas.
Bon dimanche à tous,

Ivan

 

[Theze]

Bonjour,

Ca marche mais une petite erreur c'était glissée dans "ElseIf Cel.Value = "LAP" Then" il y avait un espace en trop devant "LAP" :

Sub Test()

    Dim Plage As Range
    Dim Cel As Range
    Dim L As Long
    'défini la plage sur la colonne A à partir de A2 de la feuille "Origine"
    With Worksheets("Origine")
   
        Set Plage = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
     
    For Each Cel In Plage
        With Worksheets("Destination")
     
            Select Case Cel.Offset(, 3).Value
         
                Case "MON CLIENT"
             
                    L = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 'sur colonne A
                   
                    .Cells(L, 1).Value = Cel.Offset(, 4).Value
                    .Cells(L, 2).Value = Cel.Offset(, 3).Value
                 
                    If Cel.Value = "ABC" Then
                 
                        .Cells(L, 3).Value = Cel.Offset(, 9).Value
                        .Cells(L, 4).Value = Cel.Offset(, 11).Value
                 
                    ElseIf Cel.Value = "LAP" Then '<--- ici il y avait un espace en trop
                 
                        .Cells(L, 5).Value = Cel.Offset(, 9).Value
                        .Cells(L, 6).Value = Cel.Offset(, 11).Value
                 
                    End If
                 
            End Select
             
        End With
     
    Next Cel
End Sub