XL 2016 VBA : Copie d'une ligne après application d'un filtre

gfgghbhg

XLDnaute Nouveau
Bonjour à tous,

Dans le cadre de mon travail, j'ai réalisé un fichier Excel qui contient de la matière en stock. J'ai réalisé plusieurs macros permettant d'insérer, de rechercher des éléments dans la base de données..
Le problème que je rencontre est sur la macro de "changement de feuille", lancé par le bouton "passage de stock à utiliser".
J'applique un filtre, pour ensuite copier ou couper la ligne qui ressort via le filtre. Or lors de l'opération de copier/coller, la ligne copier n'est pas celle du filtre actif mais la première ligne de la base de données sans les filtres. Je ne sais pas si je suis très clair.

Voici la macro en question.

Sub Changement_fiche()

Dim L As Integer


Sheets("Stock").Select
Lot = InputBox("Quel est le lot souhaité? ", "Saisie lot")

Sheets("Stock").Select
Range("Tableau4[[#Headers],[Numéro de lot]]").Select
ActiveSheet.ListObjects("Tableau4").Range.AutoFilter Field:=1, Criteria1:=Lot

d = [Subtotal(3, A:A)]
If d > 2 Then
Lon = InputBox("Quel est la longueur souhaité? ", "Saisie longueur")
Range("Tableau4[[#Headers],[Longueur (mm)]]").Select
ActiveSheet.ListObjects("Tableau4").Range.AutoFilter Field:=2, Criteria1:=Lon
d = [Subtotal(3, A:A)]
If d > 2 Then
Lar = InputBox("Quel est la largeur souhaité? ", "Saisie largeur")
Range("Tableau4[[#Headers],[Largeur (mm)]]").Select
ActiveSheet.ListObjects("Tableau4").Range.AutoFilter Field:=3, Criteria1:=Lar
d = [Subtotal(3, A:A)]
If d > 2 Then
Ep = InputBox("Quel est l'épaisseur souhaité? ", "Saisie épaisseur")
Range("Tableau4[[#Headers],[Epaisseur (mm)]]").Select
ActiveSheet.ListObjects("Tableau4").Range.AutoFilter Field:=4, Criteria1:=Ep
d = [Subtotal(3, A:A)]
If d <> 2 Then
Spec = InputBox("Quel est la spec souhaité? ", "Saisie spec")
Range("Tableau4[[#Headers],[Spec]]").Select
ActiveSheet.ListObjects("Tableau4").Range.AutoFilter Field:=5, Criteria1:=Spec
d = [Subtotal(3, A:A)]
End If
End If
End If
End If
If d = 1 Then
Call MsgBox("Il n'y a pas de matière sous ces données", Erreur)
ActiveSheet.ShowAllData
Exit Sub
End If
If Sheets("Stock").Range("F" & 2).Value = "Tole" Then
Sheets("Utilisé").Rows(2).Insert
Sheets("Stock").Range("A2:M2").Cut Sheets("Utilisé").Range("A2:L2")
Sheets("Stock").Select
Sheets("Stock").Rows(2).Delete
Range("Tableau4[#Headers]").Select
ActiveSheet.ShowAllData
Else
L = InputBox("Quel est le nombre de lopins à usiner ?", "Saisie lopins")
If L > Sheets("Stock").Range("G2").Value Then
Call MsgBox("Il n'y a pas autant de lopins disponible")
Sheets("Stock").Select
Range("Tableau4[#Headers]").Select
ActiveSheet.ShowAllData
ElseIf L = Sheets("Stock").Range("G2").Value Then
Sheets("Utilisé").Rows(2).Insert
Sheets("Stock").Range("A2:M2").Cut Sheets("Utilisé").Range("A2:L2")
Sheets("Stock").Select
Sheets("Stock").Rows(2).Delete
Range("Tableau4[#Headers]").Select
ActiveSheet.ShowAllData
Else
Sheets("Utilisé").Rows(2).Insert
Sheets("Stock").Range("A2:M2").Copy Sheets("Utilisé").Range("A2:L2")
Sheets("Utilisé").Range("G2") = L
Sheets("Stock").Select
Sheets("Stock").Range("G2") = Sheets("Stock").Range("G2") - L
Sheets("Utilisé").Range("L2") = L * Sheets("Utilisé").Range("J2").Value
Sheets("Utilisé").Range("M2") = L * Sheets("Utilisé").Range("K2").Value
Sheets("Stock").Range("L2") = Sheets("Stock").Range("G2") * Sheets("Stock").Range("J2").Value
Sheets("Stock").Range("M2") = Sheets("Stock").Range("G2") * Sheets("Stock").Range("K2").Value
Range("Tableau4[#Headers]").Select
ActiveSheet.ShowAllData
End If
End If
Dim DateSheet
DateSheet = InputBox("Quel est le jour de l'utilisation de cette matière ?", Date)
Sheets("Utilisé").Select
Range("N2").Select
ActiveCell.FormulaR1C1 = DateSheet
Call Somme_Stock
Call Somme_Utilisé
Sheets("Utilisé").Select
d = Cells(Rows.Count, 1).End(xlUp).Row
Rows("2:" & d).Font.Color = RGB(0, 0, 0)
Rows("2:" & d).Font.Bold = False
End Sub




Merci à vous pour votre aide futur
 

Pièces jointes

  • test m - Copie.xlsm
    414.8 KB · Affichages: 8
Solution
Bonjour et bienvenue sur XLD :)

Voici une fonction VBA qui retourne le numéro de ligne de la première ligne filtrée dt tableau structuré filtré.
  • en valeur absolue (par rapport à la feuille du tableau structuré)
  • en valeur relatif (par rapport à la première ligne des données du tableau)
  • renvoie0 le nombre 0 si le filtre ne retourne aucune ligne
Si le deuxième paramètre est présent (et vaut n'importe quoi) alors on retourne la valeur "en relatif).



La fonction en VBA à mettre dans un module ordinaire :
VB:
Function PremLigne(Tableau As ListObject, Optional relatif) As Long
Dim deb&, Lig1&, lig2&, i&
   With Tableau
      If .ListRows.Count = 0 Then Exit Function
      deb = .Range.Row + 1: Lig1 = deb: lig2 = deb +...

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour et bienvenue sur XLD :)

Voici une fonction VBA qui retourne le numéro de ligne de la première ligne filtrée dt tableau structuré filtré.
  • en valeur absolue (par rapport à la feuille du tableau structuré)
  • en valeur relatif (par rapport à la première ligne des données du tableau)
  • renvoie0 le nombre 0 si le filtre ne retourne aucune ligne
Si le deuxième paramètre est présent (et vaut n'importe quoi) alors on retourne la valeur "en relatif).



La fonction en VBA à mettre dans un module ordinaire :
VB:
Function PremLigne(Tableau As ListObject, Optional relatif) As Long
Dim deb&, Lig1&, lig2&, i&
   With Tableau
      If .ListRows.Count = 0 Then Exit Function
      deb = .Range.Row + 1: Lig1 = deb: lig2 = deb + .ListRows.Count - 1
      For i = Lig1 To lig2
         If .Parent.Rows(i).Hidden = False Then Exit For
      Next i
      If i > lig2 Then Exit Function
      PremLigne = IIf(IsMissing(relatif), i, i - deb + 1)
   End With
End Function

La fonction test() associée au bouton:
Sub test()
   MsgBox "En absolu : " & PremLigne(Sheets("Feuil1").ListObjects("Tableau1"))
   MsgBox "En relatif : " & PremLigne(Sheets("Feuil1").ListObjects("Tableau1"), 123)
End Sub

nota: choisir un pseudo à peu près compréhensible, permet de se souvenir de vous et de vos demande o_O
 

Pièces jointes

  • Pgfgghbhg- PremLigne Tableau Struc filtré- v1.xlsm
    21.6 KB · Affichages: 6

gfgghbhg

XLDnaute Nouveau
Bonjour,

Merci pour votre réponse,
Je comprends le fonctionnement, mais je ne sais pas comment l'intégrer dans ma ligne de C/C ci dessous
Sheets("Stock").Range("A2:M2").Copy Sheets("Utilisé").Range("A2:L2")

J'ai essayé de remplacer par cela, avec L la valeur de la ligne de la feuille
Sheets("Stock").Range("A" & L & ":M" & L).Copy Sheets("Utilisé").Range("A2:L2")

Pouvez-vous m'indiquer la démarche à réaliser svp ?

Ps : Etant un gameur à mes heures perdues, je suis sous ce pseudo depuis plusieurs années (je ne trouvais pas de pseudo qui me convenait et donc fait un spam click sur ma console. Depuis, j'ai toujours gardé ce pseudo ^^
 

Phil69970

XLDnaute Barbatruc
Bonjour @gfgghbhg et @mapomme

Avec la même idée que @mapomme

Plutôt que de faire entrer 5 fois des valeurs à l'utilisateur avec les risques d'erreur * 5, j'ai commencé ceci :
==> Voir feuille stock
Tu as des tableaux structurés tu peux aussi t'en servir pour faire des calcul.... (voir colonne L et M feuille stock)

La suite suivant ton approbation ou pas !!!

@Phil69970
 

Pièces jointes

  • Selection et copie entre TS V1.xlsm
    447.1 KB · Affichages: 6

gfgghbhg

XLDnaute Nouveau
Bonjour @Phil69970,

Merci pour ta proposition. Le problème est qu'à l'avenir les feuilles stock et utilisé seront masqué. D'où le fait que je souhaite entrer 5 fois les valeurs.

Merci de ta proposition.

Gf

Ps: Etant en vacance ce soir je ne serais pas disponible avant milieu de semaine prochaine pour répondre à vos potentielles solutions.
 
Dernière édition:

gfgghbhg

XLDnaute Nouveau
Bonjour @mapomme,

Je reviens de vacances, et est donc pu tester votre solution plus en profondeur. Le problème est maintenant résolu, grâce à l'obtention du numéro de ligne, en modifiant les lignes de ce type :
Sheets("Stock").Range("A2:M2").Copy Sheets("Utilisé").Range("A2:L2")
Par
Sheets("Stock").Rows(Nl).Copy Sheets("Utilisé").Range("A2:L2")
Avec Nl correspondant au numéro de la ligne trouvé avec les différents filtres.

Merci à vous pour votre aide et bonne journée.
Gf
 

Discussions similaires

Réponses
1
Affichages
1 K

Statistiques des forums

Discussions
311 733
Messages
2 082 009
Membres
101 865
dernier inscrit
MLL