Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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

G

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 +...
Trier par date Trier par votes

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
 

Pièces jointes

  • Pgfgghbhg- PremLigne Tableau Struc filtré- v1.xlsm
    21.6 KB · Affichages: 6
Vote positif 1 Vote négatif
Solution
G

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")
Cliquez pour agrandir...

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")
Cliquez pour agrandir...

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 ^^
 
Vote positif 0 Vote négatif

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
Vote positif 0 Vote négatif
G

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:
Vote positif 0 Vote négatif
G

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")
Cliquez pour agrandir...
Par
Sheets("Stock").Rows(Nl).Copy Sheets("Utilisé").Range("A2:L2")
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
XL 2021 Filtrage que je ne parviens pas à faire
Réponses
6
Affichages
560
Usine à gaz
S
  • Résolu(e)
Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
2
Réponses
23
Affichages
2 K
AtTheOne
K
  • Résolu(e)
XL 2019 Copier Seulement les lignes affichée après un filtre de tableau
Réponses
9
Affichages
1 K
Kushi
K
C
  • Résolu(e)
XL 2016 Remplir automatiquement un tableau d'après des conditions et des valeurs
Réponses
11
Affichages
1 K
ERIC S
F
  • Question
Microsoft 365 Optimisation code VBA - Succession de copier coller
Réponses
8
Affichages
2 K
flomag
F
P
  • Question
XL 2016 Macro, Copier coller des cellules fusionnées en fonction d'un texte
Réponses
1
Affichages
741
Deadpool_CC
  • Résolu(e)
XL 2010 Tri Multi-Criteres par VBA suivant valeurs des cellules
Réponses
6
Affichages
2 K
LEIYAZ
R
  • Question
XL 2016 incrémentation base de données vba avec supression en partie de la ligne
Réponses
4
Affichages
1 K
RobyL
R
  • Question
Microsoft 365 Simplification de code
Réponses
1
Affichages
1 K
GADENSEB
Z
  • Résolu(e)
trier une base pour creer des listes dynamiques
Réponses
3
Affichages
930
Zilba456
Z
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…