Copier des lignes dans différents onglets

Bonjour,

Je viens vers vous car je n’arrive pas à faire ce que je veux malgré mes recherches. J’ai bien trouvé une partie de ma réponse ici (https://forum.excel-pratique.com/excel/copier-automatiquement-des-lignes-d-un-onglet-vers-un-autre-s...) mais cela ne réponds pas complètement.

Alors voilà, mon doc excel (que je joint), se compose d’un onglet « 2023 » regroupant mes données et de 5 onglets portant le nom d’une cellule donnée dans « 2023 ». Param1 (correspondant à la cellule E1 de « 2023 », Param2

(correspondant à la cellule F1 de « 2023 », etc…

J’aimerais que la ligne soit copiée si « OUI » est indiqué de la colonne Param1 dans l’onglet « Param1 » et ainsi de suite pour les onglets définis.

De plus, j’aimerais que cela se produise lorsque l’on clique sur le bouton « Valider » que j’ai inséré dans l’onglet « 2023 ».

Je ne sais pas si je suis assez clair mais si une âme charitable pouvait me dépanner, j’en serais ravi ;).

Merci par avance

Spark

Bonjour

J'ai transformé tes données en tableau structuré (beaucoup plus rapide)

Ci joint ma solution

A+ François

Bonjour,

merci de m'avoir consacré un peu de temps ! Ta solution fonction bien.

Je vais la tester et te faire remonter les problèmes éventuels que j'ai pu rencontrés.

Bonne journée.

Spark

Bonjour Spark, fanfan38, le forum,

Une variante....à tester....

Option Explicit
Option Base 1
Sub test()
 Dim tb, ntb(), wsh
 Dim i%, k%, j%, x%, dl%
 Dim rcell As Range

  tb = Sheets("2023").ListObjects(1).DataBodyRange
 wsh = Array("Param1", "Param2", "Param3", "Param4", "Param5")

 Application.ScreenUpdating = False

  For i = 1 To UBound(wsh)
   k = 0
   ReDim ntb(1 To UBound(tb, 1), 1 To 4)
     For j = 1 To UBound(tb, 1)
      If UCase(tb(j, i + 4)) Like "OUI" Then
       For x = 1 To 4: ntb(k + 1, x) = tb(j, x): Next x
       k = k + 1
      End If
     Next j

     With Sheets(wsh(i)).ListObjects(1)
      If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
       If .InsertRowRange Is Nothing Then
        Set rcell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
       Else
        Set rcell = .InsertRowRange.Cells(1)
       End If
     End With
     If k > 0 Then rcell.Resize(k, 4) = ntb: Erase ntb
  Next i
 Erase tb: Set rcell = Nothing: MsgBox "Traitement effectué", vbInformation
End Sub

Cordialement,

Salut,

merci pour la proposition.

Je viens de tester et j'ai une erreur m'indiquant une erreur d'execution : "Lindice n'appartient pas à la sélection"

concernant cette partie : "With Sheets(wsh(i)).ListObjects(1)".

Re,

Merci pour le retour,

Je viens de tester et j'ai une erreur m'indiquant une erreur d'execution : "Lindice n'appartient pas à la sélection"

concernant cette partie : "With Sheets(wsh(i)).ListObjects(1)".

Tu as cette erreur avec mon fichier ou en l'adaptant au tien ?

J'ai oublié de préciser que j'ai mis les données de toutes les feuilles sous forme de tableaux structurés...

Cordialement,