URGENT: FILTER and copy filtered element

[Lipaika]

Bonjour,

Je fais un filtre et je souhaite copier toutes les cellules ainsi filtrées vers une autre feuilles. J'utilisais jusqu'à présent le code ci-dessous qui marchait mais, en cette fois, au lieu de me copier que les cellules filtrées, il m'a tout copier.

Est-ce qu'une option excel est à activer désactiver? (car mon code marchait avant je ne sais quoi)

Ou y a t'il une meilleur façon de copier les éléments filtrés.


Merci par avance

Private Sub Filter_INTRA()

    Application.Calculation = xlCalculationAutomatic
    Sheets("INTRA").Activate
    Range("A1").Select
    
    'FILTER ALL INTRA
    Sheets("INTRA_INTER_FREQ").Activate
    Sheets("INTRA_INTER_FREQ").Range("A1:E1").Select
    Selection.AutoFilter
    Selection.AutoFilter Field:=5, Criteria1:=1
    
    'copy INTRA to the INTRA sheet
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Sheets("INTRA").Activate
    ActiveSheet.Paste
    Columns(1).AutoFit
    Columns(2).AutoFit

    'delete all except from column 1 and 2
    Columns(3).Select
    Range(Selection, Selection.End(xlToRight)).ClearContents
    
    Dim formula_rg As String
    Range("A2").Select
    Selection.End(xlDown).Select
    NB_ligne = Selection.Row
        
    formula_rg = "C2:D" & NB_ligne
    Range("C2").Select

    ActiveCell.FormulaR1C1 = "=RC[-2]&""/""&RC[-1]"
    ActiveCell.Offset(0, 1).FormulaR1C1 = "=IF(R[-1]C[-3]<>RC[-3],0,R[-1]C+1)"
    Range("C2:D2").Select
    Selection.AutoFill Destination:=Range(formula_rg)
    Application.Calculation = xlCalculationAutomatic
    
    Range("C1").Value = "UniqID"
    Range("D1").Value = "Number of Neighbour"
    
    Columns("C:D").Copy
    ActiveSheet.Columns("C:D").PasteSpecial Paste:=xlPasteValues
    Columns("C:D").AutoFit
    Application.CutCopyMode = False
    
End Sub

 

[Staple1600]

Re : URGENT: FILTER and copy filtered element

Bonjour

Sans macro (ou avec ...)

Edition/Atteindre/Cellules/Zone en cours
ou Cellules visibles

Copier/Coller dans la destination de ton choix

(à traduire en vba avec l'enregistreur de macro)

 

[Lipaika]

Re : URGENT: FILTER and copy filtered element

oui merci,

C'est ce que j'avais fais en l'occurence.
Et ça marchait.
J'ai relancé la macro en mode debug, même chose.
J'ai essayé de le faire à la main, et là, dès que je fais le copier un message me dit que ce copiage est trop complexe.

Il prend donc tout pour le copier vers la feuile destination.

Mon cas est particulier car je travaille sur un fichier de 50000 lignes.

 

[Compte Supprimé 979]

Re : URGENT: FILTER and copy filtered element

Bonjour,

Si je peux me permettre, moi j'aimerais dire juste une chose.

Lorsqu'une feuille Excel contient plus de 10000 /20000 lignes, il faut commencer à penser : Access.

Parce-que malheureusement, par retour d'expérience, tôt ou tard, ce genre de fichier finit par casser !

Sinon, en ce qui concerne ta macro, pour contourner le problème, ce serait de copier les lignes une à une 😕

A+

 

[Foufoudora]

Re : URGENT: FILTER and copy filtered element

Bonjour Lipaika, Staple1600, BrunoM45 et le forum

je ne sais pas si ca peut t'aider, mais tu peux voir cette macro qui te copie toute la zone filtrée sur la feuille 2. je remercie fortement Chti160 qui m'a aidé à la faire qui je le salue fortement.
et joyeuses fêtes de pâques à tout le monde

code :

Sub copieV2()
Dim Maplage As Range
Dim Derlgn As Integer
Dim Dercol As Byte
With Sheets("Feuil1")
Derlgn = .Range("A65536").End(xlUp).Row
Dercol = .Range("IV1").End(xlToLeft).Column
Set Maplage = .Range(.Cells(1, 1), .Cells(Derlgn, Dercol)).SpecialCells(xlCellTypeVisible)
End With
With Sheets("Feuil2")
Derlgn = .Range("A65536").End(xlUp).Row
Dercol = .Range("IV1").End(xlToLeft).Column
.Range(.Cells(1, 1), .Cells(Derlgn, Dercol)).ClearContents
Maplage.Copy Destination:=.Range("A1")
End With
End Sub

Salutations

 

[Lipaika]

Re : URGENT: FILTER and copy filtered element

Merci Foufoudora,

Ca ne fonctionne pas non plus car ça reste un copy sur une selection complexe puisque filtrée.

Donc je vais tester deux méthodes :

1. tout copier puis supprimer les lignes indésirables qui sont à priori moins nombreuses (40% du tout)

2. copier seulement les utiles.

je vais faire les 2 et tester la méthode la plus optimisée bien que j'ai mon idée sur la question.

Merci à vous

 

[Staple1600]

Re : URGENT: FILTER and copy filtered element

Re

Et c'est quoi ton idée sur la question, stp?

 

[Foufoudora]

Re : URGENT: FILTER and copy filtered element

Salut tout le monde, Lipaika,

c'est bizarre parce que la macro fonctionne à merveille.
peux tu mettre un fichier exemple ?

voir mon fichier joint. je suis sous excel 2003.

Je me permets de le remettre sur le forum après le crash, si ca peut aider quelqu'un.
( rendre à Cesar ce qui est à Cesar et à Dieu ce qui est à Dieu )

tu as 2 macros.

Salutations

 

[ChTi160]

Re : URGENT: FILTER and copy filtered element

Salut Lipaika
Bonjour le Fil,Le Forum
un coucou particulier à Foufoudora

effectivement pas clair Lol
Le Titre du post

FILTER and copy filtered element

réponse de l'initiateur du post

Ca ne fonctionne pas non plus car ça reste un copy sur une selection complexe puisque filtrée

arff mais cela ne doit pas être loin Lol

Bonne fin de Journée

 

[Lipaika]

Re : URGENT: FILTER and copy filtered element

Je n'ai pas dit que ça ne marchait pas!!

Je dis simplement que le nombre de lignes est limité.

Quand je travaillais avec des fichiers de 30000 lignes, ma macro marchait, la tienne également.

Mais j'ai 50 000 lignes que je filtre, il en reste 36 000 après filtrage. et là blocage.

Attention à déclarer ton nb de ligne en long sinon overflow si tu ve tester.

par ailleurs pour avoir la dernière ligne tu peux utiliser simplement :
Derlgn = Rows(Sheets("Sheet2").UsedRange.Rows.Count + 1).Row

Merci quand même de ton acharnement, c'est comme ça que l'on avance!!

 

[ChTi160]

Re : URGENT: FILTER and copy filtered element

Salut Lipaika
re le post
arff j'ai fait une petite macro qui transfère (pour mon test et avec ma machine lol) 31600 lignes sur 65535 en 8 à 9 secondes environ (pour 4 colonnes) 32 secondes pour le même nombre de lignes sur 10 colonnes
à Voir Lol

Sub CopieV3()
Dim Maplage As Range
Dim Derlgn As Long
Dim Dercol As Byte, C As Byte
Dim Tableau_Recup() As Variant
Dim x As Long
Dim TimeDepart As Double
Dim TimeFin As Double
          x = -1
               TimeDepart = Timer
With Sheets("Feuil1")
      Derlgn = .Range("A65536").End(xlUp).Row
      Dercol = .Range("IV1").End(xlToLeft).Column
         Set Maplage = .Range(.Cells(1, 1), .Cells(Derlgn, Dercol))
     
 End With
With Sheets("Feuil2")
    Derlgn = .Range("A65536").End(xlUp).Row
    Dercol = .Range("IV1").End(xlToLeft).Column
                .Range(.Cells(1, 1), .Cells(Derlgn, Dercol)).ClearContents
  For L = 1 To Maplage.Rows.Count
    If Cells(L, 1).EntireRow.Hidden = False Then
                 x = x + 1
           ReDim Preserve Tableau_Recup(Maplage.Columns.Count, x)
        For C = 0 To Maplage.Columns.Count - 1
           Tableau_Recup(C, x) = Maplage.Cells(L, 1 + C)
        Next
    End If
  Next
  
     .Range("A1").Resize(UBound(Tableau_Recup, 2) + 1, _
           UBound(Tableau_Recup, 1)) = Application.Transpose(Tableau_Recup)

End With
     
             TimeFin = Timer
MsgBox TimeFin - TimeDepart
End Sub

Bonne fin de Journée

 

[papapaul]

Re : URGENT: FILTER and copy filtered element

😡 Puis-je me permettre ?
Quand je vois un fil avec URGENT : ca m' agace
D'office je ne répondrais pas même si j'avais la réponse.
Je préfère remercier tous les amis de ce forum qui
m'ont aider de multiples fois.🙂
Combien de fois faudra t'il rappeller que ce sont des
gens bénévoles, qui bossent, et qui prennent sur leur temps
perso pour essayer d'aider les autres.

Enervé papapaul ? 🙄

 

[Compte Supprimé 979]

Re : URGENT: FILTER and copy filtered element

Salut Papapaul,

Tiens, tu es comme moi

Moi aussi je suis allergique à ces posts de plus en plus fréquents, d'ailleur, ou il est noté URGENT 😱

Comme je le disais dans un autre post : il n'y a pas d'affaires urgentes, il n'y a que des gens pessés et en retard !

Et je fais comme toi, je laisse couler ...
La prochaine fois que je vois URGENT