XL 2019 VBA copier coller sous condition

Navillus · 22 Juin 2022

Bonjour à tout le monde,

Je souhaiterais effectuer des copier coller sous condition avec l'aide d'un code VBA. Cela dépasse malheureusement largement mes très légères connaissances en VBA. Si un expert chevronné pouvait m'aider avec ce code; je lui en serais très reconnaissant

Il s'agirait de copier Feuil1.Range("A3: D3") pour le coller sur Feuil2.Range("A15:G15") uniquement si la valeur de D3 est un chiffre (ou supérieur à 0). Et de renouveler l'opération pour toutes les lignes d'en dessous. Idem pour le tableau Logistique situé en feuil1. Le but étant que la macro copie et colle toutes les lignes présentant une quantité dans la feuil2 en commençant par ligne 15 jusque ligne 27, pour reprendre ligne 36

Si la ligne 27 de la feuil2 est remplie, je souhaiterais que la macro passe à la ligne 36 pour coller la suite.

Pour finir, une fois notre copie effectuée, je souhaiterais que le code VBA copie colle "O31" en "C31" si le remplissage s'arrête en ligne 27 ou en "C84" si le remplissage va au delà de la ligne 27.

J'ajoute que les colonne B, C, D, E de la Feuil2 sont fusionnées; espérant que cela ne posera pas de soucis lors du collage.

Je vous mets une copie d'un fichier test (ce n'est pas mon fichier original) afin que vous puissiez voir plus simplement.

Je remercie vivement les personnes qui prendront le temps de se pencher sur mon problème.

Navillus · 22 Juin 2022

Avec le fichier c'est mieux

vgendron · 22 Juin 2022

Hello
un essai en PJ

Navillus · 22 Juin 2022

vgendron à dit:
Hello
un essai en PJ

Bonjour Vgendron,

Merci pour votre réponse.
La macro me rempli les lignes 28 à 35. Et elle ne me copie pas la totalité des lignes présentant des quantités
Et le macro me met "FIN" dans les 2 cellules au lieu d'une seule.

Y a t-il un moyen d'arranger ça?

Merci d'avance pour votre aide.

vgendron · 22 Juin 2022

avec cette correction

VB:

Sub dispatch()
Dim TabSource1() As Variant
Dim TabSource2() As Variant


TabSource1 = Range("Tableau1").Value 'on met les tableaux structurés dans des tablo vba
TabSource2 = Range("Tableau2").Value

With Sheets("Feuil2")
    .Range("A15:G27").ClearContents
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    If fin > 35 Then
        .Range("A36:G" & fin).ClearContents
    End If
    For i = LBound(TabSource1, 1) To UBound(TabSource1, 1) 'on parcourt le tableau1
        If TabSource1(i, 4) <> "" Then 'la ligne doit etre copiée
            ligne = .Range("A35").End(xlUp).Row + 1
            If ligne = 28 Then
                ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
            .Range("A" & ligne) = TabSource1(i, 1)
            .Range("B" & ligne) = TabSource1(i, 2)
            .Range("F" & ligne) = TabSource1(i, 3)
            .Range("G" & ligne) = TabSource1(i, 4)
        End If
    Next i
    
    For i = LBound(TabSource2, 1) To UBound(TabSource2, 1) 'on parcourt le tableau1
        If TabSource2(i, 4) <> "" Then 'la ligne doit etre copiée
            ligne = .Range("A35").End(xlUp).Row + 1
            If ligne = 28 Then
                ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
            .Range("A" & ligne) = TabSource2(i, 1)
            .Range("B" & ligne) = TabSource2(i, 2)
            .Range("F" & ligne) = TabSource2(i, 3)
            .Range("G" & ligne) = TabSource2(i, 4)
        End If
    Next i
    If .Range("A36") <> "" Then
        .Range("C84") = "FIN"
    Else
        .Range("C31") = "FIN"
    End If
End With
End Sub

vgendron · 22 Juin 2022

nouvelle correction

VB:

Sub dispatch()
Dim TabSource1() As Variant
Dim TabSource2() As Variant


TabSource1 = Range("Tableau1").Value 'on met les tableaux structurés dans des tablo vba
TabSource2 = Range("Tableau2").Value

With Sheets("Feuil2")
    .Range("A15:G27").ClearContents 'on efface
    .Range("C31").ClearContents 'on efface
    fin = .Range("C" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne C
    If fin > 35 Then
        .Range("A36:G" & fin).ClearContents
    End If
    For i = LBound(TabSource1, 1) To UBound(TabSource1, 1) 'on parcourt le tableau1
        If TabSource1(i, 4) <> "" Then 'la ligne doit etre copiée
            ligne = .Range("A35").End(xlUp).Row + 1
            If ligne = 28 Then
                ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
            .Range("A" & ligne) = TabSource1(i, 1)
            .Range("B" & ligne) = TabSource1(i, 2)
            .Range("F" & ligne) = TabSource1(i, 3)
            .Range("G" & ligne) = TabSource1(i, 4)
        End If
    Next i
    
    For i = LBound(TabSource2, 1) To UBound(TabSource2, 1) 'on parcourt le tableau1
        If TabSource2(i, 4) <> "" Then 'la ligne doit etre copiée
            ligne = .Range("A35").End(xlUp).Row + 1
            If ligne = 28 Then
                ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
            .Range("A" & ligne) = TabSource2(i, 1)
            .Range("B" & ligne) = TabSource2(i, 2)
            .Range("F" & ligne) = TabSource2(i, 3)
            .Range("G" & ligne) = TabSource2(i, 4)
        End If
    Next i
    If .Range("A36") <> "" Then
        .Range("C84") = "FIN"
    Else
        .Range("C31") = "FIN"
    End If
End With
End Sub

Navillus · 22 Juin 2022

vgendron à dit:

avec cette correction

VB:

Sub dispatch()
Dim TabSource1() As Variant
Dim TabSource2() As Variant


TabSource1 = Range("Tableau1").Value 'on met les tableaux structurés dans des tablo vba
TabSource2 = Range("Tableau2").Value

With Sheets("Feuil2")
    .Range("A15:G27").ClearContents
    fin = .Range("A" & .Rows.Count).End(xlUp).Row
    If fin > 35 Then
        .Range("A36:G" & fin).ClearContents
    End If
    For i = LBound(TabSource1, 1) To UBound(TabSource1, 1) 'on parcourt le tableau1
        If TabSource1(i, 4) <> "" Then 'la ligne doit etre copiée
            ligne = .Range("A35").End(xlUp).Row + 1
            If ligne = 28 Then
                ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
            .Range("A" & ligne) = TabSource1(i, 1)
            .Range("B" & ligne) = TabSource1(i, 2)
            .Range("F" & ligne) = TabSource1(i, 3)
            .Range("G" & ligne) = TabSource1(i, 4)
        End If
    Next i
   
    For i = LBound(TabSource2, 1) To UBound(TabSource2, 1) 'on parcourt le tableau1
        If TabSource2(i, 4) <> "" Then 'la ligne doit etre copiée
            ligne = .Range("A35").End(xlUp).Row + 1
            If ligne = 28 Then
                ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
            End If
            .Range("A" & ligne) = TabSource2(i, 1)
            .Range("B" & ligne) = TabSource2(i, 2)
            .Range("F" & ligne) = TabSource2(i, 3)
            .Range("G" & ligne) = TabSource2(i, 4)
        End If
    Next i
    If .Range("A36") <> "" Then
        .Range("C84") = "FIN"
    Else
        .Range("C31") = "FIN"
    End If
End With
End Sub

Ca fonctionne à la perfection!

Merci beaucoup pour le coup de main et la rapidité d'exécution. Bravo et merci

XL 2019 VBA copier coller sous condition

Navillus

XLDnaute Nouveau

Navillus

XLDnaute Nouveau

Pièces jointes

vgendron

XLDnaute Barbatruc

Pièces jointes

Navillus

XLDnaute Nouveau

vgendron

XLDnaute Barbatruc

vgendron

XLDnaute Barbatruc

Navillus

XLDnaute Nouveau

Discussions similaires