XL 2016 Copie/Colle plusieurs feuille si quantité

dreamy

XLDnaute Nouveau
Bonjour,

Je sollicite votre aide car je souhaite améliorer un fichier que j'utilise quotidiennement mais je ne trouve pas l'angle d'attaque (j'ai tenter l'enregistreur de macro mais ça n'a pas fonctionner comme je voulais)

J'ai une feuille Récap qui reprends les tarif (somme des tarifs) de 2 autre feuilles ABO i et MAT i

Mais je voudrais également que l'intitulé et la quantité du produit soit copié et collé dans ma feuille Récap dans un encadré pour imprimer uniquement les produits à sortir.

D'habitude, je filtre ma colonne Quantité dans mes 2 feuilles afin de n'avoir que celle qui ont une quantité, je copie/colle manuellement chaque feuille dans Récap...

Pour la feuille ABo I : je voudrais copié l'intitulé en colonne B et la quantité colonne E dès que celle-ci est rempli
Pour la feuille Mat I : je voudrais copié l'intitulé en colonne B et la quantité colonne D dès que celle-ci est rempli

et collé les infos dans la feuille Récap :
Quantité dans la colonne T et intitulé dans la colonne U - les une à la suite des autres

Je vous ai joins un mini fichier pour aider à visualiser, j'ai réduit au maximum les données pour que ce soit clair.

Merci par avance de votre aide,
 

Pièces jointes

  • tableau test.xlsm
    42.5 KB · Affichages: 17

vgendron

XLDnaute Barbatruc
Hello

un essai avec ce code
VB:
Sub Recap()
Application.ScreenUpdating = False

With Sheets("ABO I")
    fin = .Range("B" & .Rows.Count).End(xlUp).Row
    .Range("$B$2:$G$" & fin).AutoFilter Field:=4, Criteria1:="<>"
    .Range("B3:G" & fin).SpecialCells(xlCellTypeVisible).Columns(4).Copy Destination:=Sheets("Récap").Range("T" & Rows.Count).End(xlUp).Offset(1, 0)
    .Range("B3:G" & fin).SpecialCells(xlCellTypeVisible).Columns(1).Copy Destination:=Sheets("Récap").Range("U" & Rows.Count).End(xlUp).Offset(1, 0)
    .UsedRange.AutoFilter
End With

With Sheets("MAT I")
    fin = .Range("B" & .Rows.Count).End(xlUp).Row
    .Range("$B$2:$E$" & fin).AutoFilter Field:=3, Criteria1:="<>"
    .Range("B3:E" & fin).SpecialCells(xlCellTypeVisible).Columns(3).Copy Destination:=Sheets("Récap").Range("T" & Rows.Count).End(xlUp).Offset(1, 0)
    .Range("B3:E" & fin).SpecialCells(xlCellTypeVisible).Columns(1).Copy Destination:=Sheets("Récap").Range("U" & Rows.Count).End(xlUp).Offset(1, 0)
    .UsedRange.AutoFilter
End With
Application.ScreenUpdating = True
End Sub

ATTENTION !! tu dois supprimer la fusion des cellules de ta colonne U feuille Récap.
 

dreamy

XLDnaute Nouveau
Bonjour,

Merci d'avoir pris le temps de m'aider. J'ai testé, le code fonctionne parfaitement pour le c/c, merci beaucoup pour ça.

Cependant, si je fais une modification de quantité, ou que je rajoute un article, il ne le prends pas en compte. Même en supprimant les éléments dans Récap et en relançant la macro, il ne se met pas à jour, il garde uniquement les articles du départ.
Y-a-t'il un moyen pour qu'ils se mettent à jour ?
Et comment puis-je faire pour qu'il fasse le c/c sans la mise en forme ?

Merci par avance,
 

dreamy

XLDnaute Nouveau
Je viens de faire des tests sur mon fichier. Une partie fonctionne seulement :( je m'explique :

Au delà de certaines lignes la macro ne c/c plus rien. Je pensais que cela venait de mon tableau mais sur votre fichier j'ai le même souci.
Si je mets une quantité dans la page Mat I sur l'article mat17 par exemple il n'est pas pris en compte dans Récap. Le filtre se fait bien pourtant, les colonnes sont les bonnes....

Sur le vrai fichier j'ai environ 200/300 lignes par pages, j'ai fais des tests et systématiquement, il prends en comptes que les 1ère lignes en Mat I et une seule ligne en Abo I.
J'ai c/c la macro sans modification dans mon fichier, ils sont identique. La seule "différence", c'est la quantité de ligne plus importante et qu'ils sont par famille :

(Une ligne avec intitulé / frais / quantité est insérer à chaque nouvelle famille) etc ... je pensais que c'était à cause de cela que la macro bloquait (le filtre prends "Qté" en compte) donc j'ai supprimé toutes les lignes des familles, mais la problème persiste.

upload_2018-9-13_16-11-37.png


Avez vous une idée ? :oops:
 

Pièces jointes

  • upload_2018-9-13_16-8-3.png
    upload_2018-9-13_16-8-3.png
    15 KB · Affichages: 14

vgendron

XLDnaute Barbatruc
Effectivement.. je ne comprend pas non plus...

autre méthode
VB:
Sub Recap2()
Application.ScreenUpdating = False
Dim TabAbo() As Variant
Dim TabMat() As Variant
With Sheets("ABO I")
    Fin = .Range("B" & .Rows.Count).End(xlUp).Row
    TabAbo = .Range("B3:G" & Fin).Value
End With

With Sheets("MAT I")
    Fin = .Range("B" & .Rows.Count).End(xlUp).Row
    TabMat = .Range("B3:E" & Fin).Value
End With

With Sheets("Récap")
    FinRecap = .Range("T" & .Rows.Count).End(xlUp).Row
    If FinRecap > 14 Then .Range("T15:U" & FinRecap).ClearContents
    For i = LBound(TabAbo, 1) To UBound(TabAbo, 1)
        If TabAbo(i, 4) <> "" Then
            .Range("T" & .Rows.Count).End(xlUp).Offset(1, 0) = TabAbo(i, 4)
            .Range("U" & .Rows.Count).End(xlUp).Offset(1, 0) = TabAbo(i, 1)
        End If
    Next i
   
    For i = LBound(TabMat, 1) To UBound(TabMat, 1)
        If TabMat(i, 3) <> "" Then
            .Range("T" & .Rows.Count).End(xlUp).Offset(1, 0) = TabMat(i, 3)
            .Range("U" & .Rows.Count).End(xlUp).Offset(1, 0) = TabMat(i, 1)
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub
 

vgendron

XLDnaute Barbatruc
et au vu des images que tu as postées..
il va sans doute falloir corriger comme suit
VB:
Sub Recap2()
Application.ScreenUpdating = False
Dim TabAbo() As Variant
Dim TabMat() As Variant
With Sheets("ABO I")
    Fin = .Range("B" & .Rows.Count).End(xlUp).Row
    TabAbo = .Range("B3:G" & Fin).Value
End With

With Sheets("MAT I")
    Fin = .Range("B" & .Rows.Count).End(xlUp).Row
    TabMat = .Range("B3:E" & Fin).Value
End With

With Sheets("Récap")
    FinRecap = .Range("T" & .Rows.Count).End(xlUp).Row
    If FinRecap > 14 Then .Range("T15:U" & FinRecap).ClearContents
    For i = LBound(TabAbo, 1) To UBound(TabAbo, 1)
        If TabAbo(i, 4) <> "" And IsNumeric(TabAbo(i, 4)) Then
            .Range("T" & .Rows.Count).End(xlUp).Offset(1, 0) = TabAbo(i, 4)
            .Range("U" & .Rows.Count).End(xlUp).Offset(1, 0) = TabAbo(i, 1)
        End If
    Next i
   
    For i = LBound(TabMat, 1) To UBound(TabMat, 1)
        If TabMat(i, 3) <> "" And IsNumeric(TabAbo(i, 3)) Then
            .Range("T" & .Rows.Count).End(xlUp).Offset(1, 0) = TabMat(i, 3)
            .Range("U" & .Rows.Count).End(xlUp).Offset(1, 0) = TabMat(i, 1)
        End If
    Next i
End With
Application.ScreenUpdating = True
End Sub

Si il y a encore un souci, poste plutot ton fichier. ce sera plus pratique et efficace pour identifier les pb
 

dreamy

XLDnaute Nouveau
Bonjour,

Je viens de tester ... et ça marche à la perfection !!! merci de votre aide et de m'avoir accordé votre temps !
Il y avait une petite erreur de Tab (TabAbo au lieu de TabMat) vers la fin mais j'ai modifié le nom et tout fonctionne !
J'ai plus qu'a rajouter toutes les pages manquantes maintenant.

un GRAND merci ! toute seule j'y serai pas arrivé la ! :D:D:D:D
 

Discussions similaires

Réponses
3
Affichages
150

Statistiques des forums

Discussions
311 721
Messages
2 081 927
Membres
101 842
dernier inscrit
seb0390