XL 2019 VBA copier coller sous condition

Navillus

XLDnaute Nouveau
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.
 

vgendron

XLDnaute Barbatruc
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

XLDnaute Barbatruc
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

XLDnaute Nouveau
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 :)
 

Discussions similaires

Statistiques des forums

Discussions
311 715
Messages
2 081 822
Membres
101 822
dernier inscrit
holale