XL 2019 Sélectionner et exporter toutes les lignes contenant la valeur VRAI dans la dernière colonne VBA

[bluesky12000]

Bonjour à tous,

Dans une base de données à filtrer, j'ai mis un checkbox type form control qui renvoie à la valeur VRAI ou FAUX dans la colonne L.
En parallèle, je suis en train de travailler sur une colonne à choix multiples pour indiquer un tableau de destination (1; 2; etc..) et dont l'information serait en colonne M.

Après avoir parcouru toute ma base de données et coché toutes les lignes qui m'intéressent et leurs tableaux de destination, je souhaiterais copier quelques colonnes (exemple : A,G,H) et les exporter sous le(s) tableau(x) déjà créés par exemple Tableau1 et Tableau2.

Si une ligne de la base de données est cochée et comporte dans le choix multiple en colonne M : 1, elle irait dans le Tableau1.
Si une ligne comporte en colonne M : 1 ; 2, elle irait se rajouter à ces 2 tableaux.

Comment pourrais-je arriver à ce résultat en utilisant du VBA ?

Je vous joins mon fichier en exemple.

Merci d'avance pour votre aide toujours si précieuse

 

[mapomme]

Bonsoir @bluesky12000,

Un essai dans le fichier joint.
On efface les précédentes résultats des trois tableaux qui on,t été renommés Tableau1, Tableau2 et Tableau3.
Cliquez sur le bouton Hop!

Le code de la macro VBA:

Sub Ventiler()
Dim t, i&, j&, k&, Struc As ListObject, ligne

   Application.ScreenUpdating = False
   With Sheets("BDD"):   t = .ListObjects(1).DataBodyRange: End With
   With Sheets("Export")
      For k = 1 To 3
         Set Struc = .ListObjects("Tableau" & k)
         ' mettre en commentaire la ligne suivante si on ne veut pas faire
         ' une RAZ des tableaux mais y ajouter les données.
         For i = 1 To Struc.ListRows.Count: Struc.ListRows(1).Delete: Next
         For i = 1 To UBound(t)
            If t(i, 12) And InStr(t(i, 13), k) > 0 Then
               Set ligne = .ListObjects("Tableau" & k).ListRows.Add
               ligne.Range(1, 1) = t(i, 1)
               ligne.Range(1, 2) = t(i, 7)
               ligne.Range(1, 3) = t(i, 8)
            End If
         Next i
      Next k
      .Activate
   End With
End Sub

 

[mapomme]

Re,
Bonsoir @Jacky67

Personnellement, je n'apprécie pas du tout les cases à cocher.

Voici une version où il suffit de sélectionner la cellule (en colonne K) pour inverser la sélection (X correspond à sélectionnée, vide correspond à pas sélectionnée)

 

[Staple1600]

Bonsoir le fil,

[aparté]

Re,

Personnellement, je n'apprécie pas du tout les cases à cocher.

Moi, non plus
Mauvaise expérience pendant tes 3 jours?
ou pour le passage du code ?
ou traumatisé par un Sudoku retors ?
[aparté]
Sinon très malin, l'emoji pour l'attente de fichier.
(dépose vite un brevet sur l'idée )

 

[mapomme]

Bonsoir @Staple1600

Je me suis efforcé d'utiliser la syntaxe des "ListObject" afin de m'y familiariser et m'entrainer un petit peu. Il faut bien puisque leur usage s'étend.

nota : La troisième est la plus vraisemblable pour moi.

 

[bluesky12000]

Merci mapomme pour ton travail c'est super
Concernant les cases à cocher, c'est vrai que j'ai pensé également à juste remplir la cellule avec une lettre mais je pensais que la case à cocher pouvait m'apporter plus d'option mais elle prend 2 colonnes et c'est ennuyant à lier, j'avais un code VBA pour le faire.

Pour revenir sur ton VBA, j'essaie de le comprendre depuis tout à l'heure et j'ai quelques questions :

Sub Ventiler()

'Désolé j'ai du mal avec les abrévatiations. t As ?,  i As Long, J as Long, K as Long, Struc As ListObject, ligne As ?

Dim t, i&, j&, k&, Struc As ListObject, ligne

   Application.ScreenUpdating = False

'ici le listObjects(1) aurait pu s'appeler ListObjects("BD") ?
   With Sheets("BDD"):   t = .ListObjects(1).DataBodyRange: End With
   With Sheets("Export")

'Si j'ai 10 tableaux, je dois mettre 1 to 10 ?
      For k = 1 To 3

         Set Struc = .ListObjects("Tableau" & k)
         ' mettre en commentaire la ligne suivante si on ne veut pas faire
         ' une RAZ des tableaux mais y ajouter les données.

' que signifie RAZ ? effacer le tableau ?

' que signifie le i = 1 To ?
         For i = 1 To Struc.ListRows.Count: Struc.ListRows(1).Delete: Next
         For i = 1 To UBound(t)

'le i c'est la ligne ? 11ème colonne. Donc si elle n'est pas vide et si la 12 colonne à une valeur supérieur à 0 alors
            If Len(t(i, 11)) <> 0 And InStr(t(i, 12), k) > 0 Then

'K est la valeur de cette 12ème colonne ? Comment fais-tu la distinction entre les ; ?

               Set ligne = .ListObjects("Tableau" & k).ListRows.Add
'ajouter sur la 1ère colonne du tableau la valeur en 1 première colonne du tableau de référence, etc..
               ligne.Range(1, 1) = t(i, 1)
               ligne.Range(1, 2) = t(i, 7)
               ligne.Range(1, 3) = t(i, 8)
            End If
         Next i
      Next k
      .Activate
   End With
End Sub

 

[Jacky67]

Bonsoir @Staple1600

Je me suis efforcé d'utiliser la syntaxe des "ListObject" afin de m'y familiariser et m'entrainer un petit peu. Il faut bien puisque leur usage s'étend.

nota : La troisième est la plus vraisemblable pour moi.

Hello mapomme, Staple 1600
..afin de m'y familiariser et m'entrainer....
Là, on est au moins deux, et merci pour ce bel exemple.
"cases à cocher" beurg!!

 

[bluesky12000]

J'ai crée ce code pour effacer toute la sélection. Il à l'air de fonctionner mais est-il valide pour vous ?
J'avais d'abord fait un clearcontent mais je perdais alors la possibilité de cliquer dedans.

Sub Effacer()

With ActiveSheet.ListObjects("BD")

.ListColumns(11).DataBodyRange.Value = ""

End With

End Sub

Merci et bonne soirée

 

[mapomme]

Re,

Les anciennes versions ne fonctionnent pas si le nombre de tableau est supérieur à 9.

Voici une version plus concise, plus rapide et qui permet un nombre quelconque de tableaux. Le code est un peu commenté. Vous pouvez poser des questions si vous le désirez.

 

[bluesky12000]

Re,

Les anciennes versions ne fonctionnent pas si le nombre de tableau est supérieur à 9.

Voici une version plus concise, plus rapide et qui permet un nombre quelconque de tableaux. Le code est un peu commenté. Vous pouvez poser des questions si vous le désirez.

Merci beaucoup mapomme, c'est vraiment gentil d'avoir amélioré le code et d'avoir ajouté tous ces commentaires

Bonne journée,

 

[bluesky12000]

Re,

Les anciennes versions ne fonctionnent pas si le nombre de tableau est supérieur à 9.

Voici une version plus concise, plus rapide et qui permet un nombre quelconque de tableaux. Le code est un peu commenté. Vous pouvez poser des questions si vous le désirez.

Bonjour mapomme,

Merci encore pour ton code, il m'a vraiment fait avancer sur mon projet

Est-ce que tu penses qu'il serait possible d'utiliser le même système que pour les impressions de page pour la sélection du tableau ?
Exemple : 1-8 = tableaux 1 à 8
Exemple : 1-5;8 = tableaux 1 à 5 + tableau 8 ?

Merci beaucoup et bon weekend

 

[bluesky12000]

Bonjour @mapomme , j'espère que tu vas bien.
Désolé de revenir vers toi si longtemps après. Merci pour tes codes qui me sont bien utiles.
Je me demandais si tu savais d'où pouvaient venir les lenteurs dans cette macro :
En gros cocher les cases fonctionne très bien, mais un clic droit sur n'importe quelle colonne crée un freeze assez long, peut importe la taille du tableau.

Option Explicit


Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim x As Range
   For Each x In Target
      If Not Intersect(x, Sheets("BDD").ListObjects(1).Range) Is Nothing Then
         If x.Column = Range("k1").Column And x.Row > 1 Then
            If Len(x.Value) = 0 Then x = "X" Else x = ""
         End If
      End If
   Next x
End Sub

Merci beaucoup pour ton aide,

 

[mapomme]

Bonjour @bluesky12000 ,

Essayez ce code :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim x As Range
   If Not Intersect(Target, Sheets("BDD").ListObjects(1).Range) Is Nothing Then
      For Each x In Intersect(Target, Sheets("BDD").ListObjects(1).Range)
         If x.Column = Range("k1").Column And x.Row > 1 Then
            If Len(x.Value) = 0 Then x = "X" Else x = ""
         End If
      Next x
   End If
End Sub

 

[bluesky12000]

Bonjour @bluesky12000 ,

Essayez ce code :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim x As Range
   If Not Intersect(Target, Sheets("BDD").ListObjects(1).Range) Is Nothing Then
      For Each x In Intersect(Target, Sheets("BDD").ListObjects(1).Range)
         If x.Column = Range("k1").Column And x.Row > 1 Then
            If Len(x.Value) = 0 Then x = "X" Else x = ""
         End If
      Next x
   End If
End Sub

C'est parfait, merci beaucoup @mapomme

Bonne soirée