Filtrer automatiquement puis copier coller les valeurs obtenues

Le 27/03/2022 à 18:30

Bonjour à tous,

Je manque de connaissance en VBA pour mettre en place ce que j'ai en tête, c'est pourquoi je fais appel à votre aide.

Pour résumer, voici ce que je souhaite mettre en place :

1. Filtrer la colonne A de l'onglet "DSN", avec les valeurs contenues en colonne R de l'onglet "Regroupement". Ce n’est pas un filtre en valeurs exactes mais plutôt un filtre « contient »

2. Copier coller le filtre obtenu dans l’onglet « Base » à partir de la ligne 2

Ce qu’il faut savoir c’est que ma colonne A de l’onglet DSN peut atteindre 300000 lignes ce qui peut être assez lourd (surtout quand excel réactualise mes valeurs). Ce filtre va me servir de base pour des contrôle via des formules excel (pour le coup cette partie je maitrise).

Je vous mets en PJ mon classeur allégé, ce sera plus parlant.

Vous remerciant par avance pour l'aide que vous pourrez m'apporter.

Cordialement

44test-macro.xlsm (122.96 Ko)
Le 27/03/2022 à 18:57

Bonjour,

Essayez avec ce code à placer dans un module et à lier à un bouton

Sub copier()
Dim tablo()
Dim plage As Range

'Supprime données en colonne A de la feuille Base
Sheets("Base").Range("A2:A" & Sheets("Base").Range("A" & Rows.Count).End(xlUp).Row).ClearContents

'Copie des données après filtre
With Sheets("DSN")
    Set plage = .Range("A1").CurrentRegion
    ReDim tablo(1 To plage.Rows.Count)
    For i = 2 To UBound(tablo)
        If .Range("A" & i).EntireRow.Hidden = False Then
            j = j + 1
            tablo(j) = .Range("A" & i).Value
        End If
    Next i
End With

Sheets("Base").Range("A2").Resize(j, 1) = Application.Transpose(tablo)
End Sub

Faites votre filtre dans la feuille DSN puis cliquez sur le bouton

si ok-->

Cordialement

Le 27/03/2022 à 19:31

Bonsoir Dums, Dan , le forum,

Une autre proposition assez similaire mais sans passer par le filtre...

A tester....

Sub Bouton1_Cliquer()
 Dim tb, Newtb(), i&, k&, crit

 crit = Sheets("Regroupement").Range("R1").CurrentRegion

  With Sheets("DSN")
   tb = .Range("A1").CurrentRegion
   k = 0
   For i = 1 To UBound(tb, 1)
    For j = 2 To UBound(crit, 1)
     If tb(i, 1) Like "*" & crit(j, 1) & "*" Then
      ReDim Preserve Newtb(1 To 1, 1 To k + 1)
       Newtb(1, 1 + k) = tb(i, 1)
       k = k + 1
     End If
    Next j
   Next i
  End With

  With Sheets("Base")
  On Error Resume Next
   .Range("A1").CurrentRegion.Offset(1, 0).ClearContents
   .Range("A2").Resize(UBound(Newtb, 2), 1) = Application.Transpose(Newtb)
   .Activate
  End With
 Erase tb: Erase Newtb: crit = ""
End Sub
45test-macro.xlsm (146.69 Ko)

Cordialement,

Le 27/03/2022 à 19:32

Dès que j'ai accès à mon ordi je teste votre proposition.

J'avais trouvé cette discussion https://forum.excel-pratique.com/excel/macro-filtre-en-fonction-d-une-liste-de-criteres-53866 pour filtrer automatiquement avant de copier coller. J'ai testé hier sur mon fichier mais cela ne fonctionne pas, très certainement car les valeurs à chercher doivent être exacte. Savez vous s'il y a un moyen de faire ce type de filtre automatique pour un filtre "contient les valeurs" ?

Le 27/03/2022 à 19:36

Bonsoir à tous,

Une proposition via Power Query (complément à installer pour Excel 2010 et 2013 - Nativement intégré dans les versions postérieures) :

43dums-pq-filtre-dsn-v0.xlsx (135.72 Ko)
Le 28/03/2022 à 09:27

Un grand merci à tous pour votre aide. La solution de xorsankukai est la plus adaptée dans mon cas. Je viens de faire un test et tout me semble ok. Encore merci pour ce gain de temps !

Le 28/03/2022 à 10:13

J'ai une dernière question à vous soumettre : je souhaite dupliquer l'opération avec un autre regroupement de filtre (par exemple en colonne S de l'onglet "Regroupement"), sur un autre onglet. J'ai testé en créant un second bouton, copié le 1er code, modifiant certaines valeurs. Le résultat obtenu est le même que pour le 1er bouton. (j'ai bien affecté ma nouvelle macro au bouton2)

Est ce que je dois insérer une sorte de "remise à 0", ou est ce que j'ai loupé un endroit à modifier ?

Sub Bouton2_Cliquer()
Dim tb2, Newtb2(), i&, k&, crit2

 crit2 = Sheets("Regroupement").Range("S1").CurrentRegion

  With Sheets("DSN")
   tb2 = .Range("A1").CurrentRegion
   k = 0
   For i = 1 To UBound(tb2, 1)
    For j = 2 To UBound(crit2, 1)
     If tb2(i, 1) Like "*" & crit2(j, 1) & "*" Then
      ReDim Preserve Newtb2(1 To 1, 1 To k + 1)
       Newtb2(1, 1 + k) = tb2(i, 1)
       k = k + 1
     End If
    Next j
   Next i
  End With

  With Sheets("DSN_Bordereau")
  On Error Resume Next
   .Range("A1").CurrentRegion.Offset(1, 0).ClearContents
   .Range("A2").Resize(UBound(Newtb2, 2), 1) = Application.Transpose(Newtb2)
   .Activate
  End With
 Erase tb2: Erase Newtb2: crit2 = ""
End Sub
Le 28/03/2022 à 14:29

Bonjour à tous,

Le .CurrentRegion n'est pas approprié, essaie avec

Crit2 = Sheets("Regroupement").Range("S1:S" & Sheets("Regroupement").Range("S" & Rows.Count).End(xlUp).Row)

Cordialement,

Le 28/03/2022 à 15:11

Bonjour Xorsankukai,

Avec la modification proposée tout fonctionne parfaitement ! Merci beaucoup

Cordialement,

Le 28/03/2022 à 16:46

C'est encore moi

Je viens de tester sur une base plus conséquente : mon onglet "DSN" comporte presque 140000, le résultat attendu correspond à un copier/coller de 70940 cellules pour l'onglet "Base".

Lorsque je clique sur mon bouton "Base", je retrouve bien un copier/coller sur les 70940 cellules, mais à partir de la ligne 5406, je me retrouve avec un résultat "#NA".

Une idée d'où pourrait provenir le problème ?

Le 28/03/2022 à 18:54

Bonjour

Lorsque je clique sur mon bouton "Base", je retrouve bien un copier/coller sur les 70940 cellules, mais à partir de la ligne 5406, je me retrouve avec un résultat "#NA".

Sans vouloir venir m'insérer à nouveau sur le fil, avez-vous essayer avec le code que je vous ai proposé. Juste pour savoir si vous avez la même erreur

Cordialement

Le 28/03/2022 à 19:09

Bonsoir à tous,

J'ai fait le test, effectivement si le tableau à retranscrire comporte plus de 65000 lignes, ça bug .....

Je ne maitrise pas suffisamment pour t'aider d'avantage, je pense qu'il va falloir filtrer avant puis retranscrire les données ensuite.....comme le suggérait Dan depuis le début...

Après recherche, la limite pour Application.transpose est atteinte......, il va falloir procéder autrement.......

Sub Bouton1_Cliquer()
 Dim tb, Newtb(), i&, k&, crit

 crit = Sheets("Regroupement").Range("R1").CurrentRegion

  With Sheets("DSN")
   tb = .Range("A1").CurrentRegion
   k = 0
   ReDim Newtb(0 To UBound(tb, 1), 1 To 3)
   For i = 1 To UBound(tb, 1)
    For j = 2 To UBound(crit, 1)
     If tb(i, 1) Like "*" & crit(j, 1) & "*" Then
       Newtb(k, 1) = tb(i, 1)
       Newtb(k, 2) = Left(tb(i, 1), 14)
       Newtb(k, 3) = Mid(tb(i, 1), 16, 99)
       k = k + 1
     End If
    Next j
   Next i
  End With

  If k > 0 Then
    With Sheets("Base")
    On Error Resume Next
     .Cells.Borders.LineStyle = xlLineStyleNone
     .Range("A1").CurrentRegion.Offset(1, 0).ClearContents
     .Range("A2").Resize(k, 3).Value = Newtb
     .Range("D2").FormulaR1C1 = "=IF(RC[-2]=""S21.G00.30.001"",RC[-1],R[-1]C)"
     .Range("D2:D" & .Range("A" & Rows.Count).End(xlUp).Row).FillDown
     .Range("A1").CurrentRegion.Borders.Weight = xlThin
     .Activate
    End With
  End If
 Erase tb: Erase Newtb: crit = ""
End Sub

https://forum.excel-pratique.com/excel/limitation-application-transpose-124094

Testé avec 239 000 lignes en DSN : résultat==> 89 992 en BASE ..

Cordialement,

Le 28/03/2022 à 19:43

Bonsoir à tous,

Dan a écrit :

Sans vouloir venir m'insérer à nouveau sur le fil

M'enfin ! Pourquoi donc ne seriez-vous pas légitime à intervenir ?

Le 28/03/2022 à 19:52

Re,

M'enfin ! Pourquoi donc ne seriez-vous pas légitime à intervenir ?

Remarque partagée,
J'ai toujours plaisir à vous lire Dan et JFL, .

Amicalement,
Le 29/03/2022 à 10:24

Bonjour JFL, Xorsankukai,

M'enfin ! Pourquoi donc ne seriez-vous pas légitime à intervenir ?

Juste par respect de vos propositions et par rapport au choix de Dums.
Afin que Dums ne se perde pas dans les propositions, je ne souhaitais pas venir "polluer" vos solutions en interférant avec la mienne qui est un peu différente.

Attendons le retour de Dums

Amicalement

Le 29/03/2022 à 10:56

Bonjour à tous,

J'étais justement en train de retester la proposition de Dan. D'ailleurs si j'avais testé celle de Xorsankukai en premier, c'est qu'elle intégrait le filtre en automatique.
Pour le coup j'ai le même problème dans les 2 cas, même si je filtre manuellement puis utilise le code de Dan je me retrouve avec des #NA (mais cette fois ci à la ligne 12755).

Dans les 2 cas on utilise Application.Transpose ce qui peut expliquer le problème.

Le 29/03/2022 à 11:01

Bonjour à tous,

Je ne rencontre plus de souci avec :

Sub Bouton1_Cliquer()
 Dim tb, Newtb(), i&, k&, crit

 crit = Sheets("Regroupement").Range("R1:R" & Sheets("Regroupement").Range("R" & Rows.Count).End(xlUp).Row)

  With Sheets("DSN")
   tb = .Range("A1").CurrentRegion
   k = 0
   ReDim Newtb(0 To UBound(tb, 1), 1 To 1)
   For i = 1 To UBound(tb, 1)
    For j = 2 To UBound(crit, 1)
     If tb(i, 1) Like "*" & crit(j, 1) & "*" Then
       Newtb(k, 1) = tb(i, 1)
       k = k + 1
     End If
    Next j
   Next i
  End With

  If k > 0 Then
    With Sheets("Base")
    On Error Resume Next
     .Cells.Borders.LineStyle = xlLineStyleNone
     .Range("A1").CurrentRegion.Offset(1, 0).ClearContents
     .Range("A2").Resize(k, 1).Value = Newtb
     .Range("A1").CurrentRegion.Borders.Weight = xlThin
     .Activate
    End With
  End If
 Erase tb: Erase Newtb: crit = ""
End Sub

Car plus de Transpose......

N'est-ce pas le cas chez toi ?

Cordialement,

Le 29/03/2022 à 11:16

Votre dernière proposition fonctionne également chez moi (j'ai testé un fichier encore plus long !)

Je crois bien que cette fois ci est la bonne !

Merci à tous d'avoir cherché et proposé des solutions pour moi !

Le 29/03/2022 à 12:30

Bonjour à tous !

Dan a écrit :

M'enfin ! Pourquoi donc ne seriez-vous pas légitime à intervenir ?

Juste par respect de vos propositions et par rapport au choix de Dums.
Afin que Dums ne se perde pas dans les propositions, je ne souhaitais pas venir "polluer" vos solutions en interférant avec la mienne qui est un peu différente.

Je m'attendais, avec toute la pudeur qui vous caractérise, à ce type de réponse !

Cependant je ne partage pas votre sentiment.

Là où vous imaginez une "pollution" moi je rencontre de la diversité....

Et les esprits chagrins sont heureusement peu nombreux...

Par ailleurs, je pars du principe que nos amis demandeurs sont à même de faire le meilleur choix, c'est à dire celui avec lequel ils seront le plus à l'aise.

Rechercher des sujets similaires à "filtrer automatiquement puis copier coller valeurs obtenues"