Microsoft 365 Copie d'une ligne vers une autre feuille VBA

[Gadget14]

Je cherche une façon pour copier une ligne entière qui contient un texte spécifique (F.L.R) dans la colonne J à partir d'une feuille (Tableau) vers une autre feuille (F.L.R) et que le tout se fait automatiquement lorsque j'entre les données dans la feuille principale(Tableau).

 

[Dranreb]

Bonjour.
Peut être comme ça dans le module de l'objet Worksheet qui représente la feuille concernée :

Private Sub Worksheet_Change(ByVal Target As Range)
   If Intersect(Me.[J:J], Target) Is Nothing Then Exit Sub
   If Target.Value <> "F.L.R" Then Exit Sub
   With Worksheets("F.L.R").UsedRange
      Target.EntireRow.Copy Destination:=.Rows(.Rows.Count).Offset(1)
      End With
   End Sub

 

[Gadget14]

J'ai essayé et ça ne semble pas fonctionner. Je joint le fichier. En résumé, dans la feuille Tableau on entre les données sur chaque ligne selon un dossier de soumission. J'aimerais que lorsque dans la colonne J on entre les initiales d'un estimateur, cette même ligne soit transférer dans la feuille avec ses initiales. Donc je cherche la façon de faire pour que ce soit appliquer à mes 4 estimateurs

 

[Dranreb]

Dans le module Feuil1 (Tableau) :

Option Explicit
Private LOtSrc As ListObject
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim LOtDst As ListObject, LSrc As Long
   If LOtSrc Is Nothing Then Set LOtSrc = Me.ListObjects(1)
   If Intersect(LOtSrc.ListColumns("Es. Géo").DataBodyRange, Target) Is Nothing Then Exit Sub
   On Error Resume Next
   Set LOtDst = ThisWorkbook.Worksheets(Target.Value).ListObjects(1)
   If Err Then Exit Sub
   On Error GoTo 0
   LSrc = Target.Row - LOtSrc.HeaderRowRange.Row
   LOtDst.ListRows.Add.Range.Value = LOtSrc.ListRows(LSrc).Range.Value
   End Sub

Remarque: la ligne est comme il se doit ajoutée en fin de tableau.
Autre remarque: Ne vaudrait-il pas mieux que l'intégralité du tableau soit reconstitué à l'activation des feuilles ?

 

[Dranreb]

Pour appliquer ma dernière proposition, dans un module standard :

Option Explicit
Sub ExtraireEsGéo(ByVal WshCbl As Worksheet)
   Dim T(), EsGéo As String, CEsGéo As Integer, LSrc As Long, LCbl As Long, C As Integer
   With Feuil1.ListObjects(1)
      If .ListRows.Count > 0 Then T = .DataBodyRange.Value Else ReDim T(0 To 0, 0 To 0)
      CEsGéo = .ListColumns("Es. Géo").Index
      End With
   EsGéo = WshCbl.Name
   For LSrc = 1 To UBound(T, 1)
      If T(LSrc, CEsGéo) = EsGéo Then
         LCbl = LCbl + 1
         For C = 1 To UBound(T, 2): T(LCbl, C) = T(LSrc, C): Next C
         End If
      Next LSrc
   TableauRetaillé(WshCbl.ListObjects(1), LMax:=LCbl) = T
   End Sub
Property Let TableauRetaillé(ByVal LOt As ListObject, Optional ByVal LMax As Long = -1, TVals())
   Dim Trop As Long, CMax As Long, TFml(), F As Long
   If LMax < 0 Then LMax = UBound(TVals, 1)
   Trop = LOt.ListRows.Count - LMax
   If Trop > 0 Then
      LOt.ListRows(LMax + 1).Range.Resize(Trop).Delete xlShiftUp
   ElseIf Trop < 0 And LMax + Trop > 1 Then
      LOt.ListRows(LMax + Trop).Range.Resize(-Trop).Insert xlShiftDown, xlFormatFromLeftOrAbove
      End If
   If LMax = 0 Then Exit Property
   ReDim TFml(1 To LOt.ListColumns.Count)
   For F = 1 To UBound(TFml)
      With LOt.HeaderRowRange(2, F)
         If .HasFormula Then TFml(F) = .Formula2R1C1 Else TFml(F) = Null
         End With: Next F
   LOt.HeaderRowRange.Offset(1).Resize(LMax).Value = TVals
   For F = 1 To UBound(TFml)
      If Not IsNull(TFml(F)) Then LOt.ListColumns(F).DataBodyRange.Formula2R1C1 = TFml(F)
      Next F
   End Property

Dans tous les modules d'objets Worksheet cibles mettre simplement ce code :

Option Explicit
Private Sub Worksheet_Activate()
   ExtraireEsGéo Me
   End Sub