XL 2016 Filtrer_Liste_Critère_Copier_Coller_Valeur_autrefeuille_

[MONTREAL2020]

Bonjour,

J'ai trouvé ce code VBA en ligne qui me permet de copier une plage de lignes dont la (K) contient un critère (OUT)
Une fois filtrée, la coller dans une autre feuille.

Objectifs:
- Exécuter la macro par un bouton qui se trouve dans une autre que la base et la feuille de destination
- Coller les lignes en valeurs
- Réduire le temps d'exécution, car celle que je vient de tester prend à peu près 13 à 15 secondes.

Merci par avance
Voici le code: je sais qu'il une meilleure façon de coller sur le corps de la discussion, mais je n'ai pas su le faire.



Option Explicit

Sub Copy_out_list()

Dim x As Long
Dim y As Long
Dim c As Range
Dim rdata As Range

x = Feuil11.Range("A65536").End(xlUp).Row

y = Feuil16.Range("A65536").End(xlUp).Row + 1

Set rdata = Feuil11.Range("K2:K" & x)

If y >= 2 Then Feuil16.Range("A2:k" & y).ClearContents

For Each c In rdata

If c.Value = Feuil16.Range("K1").Value Then

Feuil11.Range("A" & c.Row & ":K" & c.Row).Copy Destination:=Feuil16.Range("A" & y).

End If

y = Feuil16.Range("A65536").End(xlUp).Row + 1

Next c

End Sub

 

[yal]

Bonjour
En l'absence de fichier exemple impossible de tester ou d'adapter. L'idée c'est de travailler en mémoire pour gagner du temps.

Sub FiltreCopie()
  Dim tbSource(), tbCible()
  Dim i As Long, j As Long, x As Long, y As Long, n As Long
  Dim clé As Variant
 
  x = Feuil11.Range("A65536").End(xlUp).Row
  y = Feuil16.Range("A65536").End(xlUp).Row + 1
 
  tbSource = Feuil11.Range("A2:K" & x).Value2
  clé = Feuil16.Range("K1").Value
  For i = 1 To UBound(tbSource)
    If tbSource(i, 11) = clé Then n = n + 1
  Next i
  ReDim tbCible(1 To n, 1 To 11)
  n = 0
  For i = 1 To UBound(tbSource)
    If tbSource(i, 11) = clé Then
      n = n + 1
      For j = 1 To UBound(tbSource, 2)
        tbCible(n, j) = tbSource(i, j)
      Next j
    End If
  Next i
 
  If y >= 2 Then Feuil16.Range("A2:k" & y).ClearContents
  Feuil16.Range("A2").Resize(UBound(tbCible), UBound(tbCible, 2)) = tbCible
 
End Sub

 

[MONTREAL2020]

Salut,

Merci pour ta réponse.

Ça marche super bien (4 secondes) pas mal.

 

[yal]

A tester. Remplacer :

  For i = 1 To UBound(tbSource)
    If tbSource(i, 11) = clé Then n = n + 1
  Next i
  'par :
  n = Application.CountIf(Feuil11.Range("K2:K" & x)), clé)

 

[MONTREAL2020]

Ca ne marche pas, la macro bloque la ligne rajoutée est en rouge

 

[MONTREAL2020]

 

[yal]

Désolé mais sans le fichier je ne peux rien faire de plus. De toute façon je ne suis même pas sûr que ce serait plus rapide et si ça l'est ce sera peut-être de quelque dixièmes de seconde. Donc autant garder ce qui marche.

 

[MONTREAL2020]

Désolé mais sans le fichier je ne peux rien faire de plus. De toute façon je ne suis même pas sûr que ce serait plus rapide et si ça l'est ce sera peut-être de quelque dixièmes de seconde. Donc autant garder ce qui marche.

Encore une fois merci