Le filtre filtre tout, il devient inefficace

Bonjour à tous,

Je viens vous voir car je fais face actuellement à un problème .

Pour contextualiser, je travaille actuellement sur un UserForm permettant la création de document. Sur l'UserForm se trouve une ComboBox (appelée "ComboBox1" dans mon exemple). Dans cette ComboBox, nous pouvons trouver le nom de Templates déjà pré-enregistrés.

Dans deux Tables étant sur la feuille "Database" (la "Table1" et la "Table2") se trouvent des informations liées aux Templates (voir screen où on peut voir les Datas gardé en mémoire).

Je souhaite que lorsqu'on sélectionne un Template dans la "ComboBox1", les informations se trouvant dans la "Table1" et la "Table2" se copient dans 2 autres Tables (voir screen2 pour voir la tête des deux autres Tables).

Mon programme marche en soit, mais je me suis rendu compte que si le filtre filtre toute la Table (1 ou 2) car on n'a pas rentré de données pour le Template sélectionné, il copiera alors toutes les valeurs de la Table (voir screen 3 où on a choisit la valeur de "Template2" dans la ComboBox "ComboBox1").

J'ai essaye de résoudre le problème en rajoutant des conditions, mais je n'ai pas réussi.

Je vous demande donc si vous saurez quelles modifications faire afin qu'il ne copie aucune valeur dans ce cas précis (voir screen 4 où on voit le résultat attendu dans le cas du screen 3)

En vous remerciant par avance,

Benoit.

PS : Voici le code

Private Sub ComboBox1()

    '----------------------------------------------------------------------
    'Je filtre la Table1 pour n'avoir que les lignes liees a mon document
    '----------------------------------------------------------------------

    Dim Filter As String
    Filter = ComboBox1.value
    ThisWorkbook.Sheets("Database").ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:=Filter

    '----------------------------------------------------------------------------------------------
    'Je copie les lignes de la Table1 et je les mets dans une autre Table dans une autre feuille
    '----------------------------------------------------------------------------------------------

    With ThisWorkbook
        .Worksheets("DataBase").Activate
        .Sheets("DataBase").ListObjects("Table1").ListColumns(1).DataBodyRange.Select
        Selection.Copy

        .Worksheets("Feuille1").Activate
        LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        Cells(LastRow, 1).Select
        Selection.PasteSpecial xlPasteValues

        .Worksheets("DataBase").Activate
        .Sheets("DataBase").ListObjects("Table1").ListColumns(2).DataBodyRange.Select
        Selection.Copy

        .Worksheets("Feuille1").Activate
        Cells(LastRow, 2).Select
        Selection.PasteSpecial xlPasteValues

        .Worksheets("DataBase").Activate
        .Sheets("DataBase").ListObjects("Table1").ListColumns(3).DataBodyRange.Select
        Selection.Copy

        .Worksheets("Feuille1").Activate
        Cells(LastRow, 3).Select
        Selection.PasteSpecial xlPasteValues

        .Worksheets("DataBase").Activate
        .Sheets("DataBase").ListObjects("Table1").ListColumns(4).DataBodyRange.Select
        Selection.Copy

        .Worksheets("Feuille1").Activate
        Cells(LastRow, 4).Select
        Selection.PasteSpecial xlPasteValues

        Application.CutCopyMode = False

        '+++++++++++++++++++++++++++++++++

    With ThisWorkbook
         .Sheets("Database").ListObjects("Table2").Range.AutoFilter Field:=1, Criteria1:=Filter
        .Worksheets("DataBase").Activate
        .Sheets("DataBase").ListObjects("Table2").ListColumns(1).DataBodyRange.Select
        Selection.Copy

        .Worksheets("Feuille1").Activate
        LastRow = ActiveSheet.Cells(Rows.Count, 7).End(xlUp).Row
        Cells(LastRow, 1).Select
        Selection.PasteSpecial xlPasteValues

        .Worksheets("DataBase").Activate
        .Sheets("DataBase").ListObjects("Table2").ListColumns(2).DataBodyRange.Select
        Selection.Copy

        .Worksheets("Feuille1").Activate
        Cells(LastRow, 8).Select
        Selection.PasteSpecial xlPasteValues

        .Worksheets("DataBase").Activate
        .Sheets("DataBase").ListObjects("Table2").ListColumns(3).DataBodyRange.Select
        Selection.Copy

        .Worksheets("Feuille1").Activate
        Cells(LastRow, 9).Select
        Selection.PasteSpecial xlPasteValues

        .Worksheets("DataBase").Activate
        .Sheets("DataBase").ListObjects("Table2").ListColumns(4).DataBodyRange.Select
        Selection.Copy

        .Worksheets("Feuille1").Activate
        Cells(LastRow, 10).Select
        Selection.PasteSpecial xlPasteValues

        Application.CutCopyMode = False

End Sub

EDIT1 : Ah oui pardon, il y a une colonne en plus sur le screen 1 mais c'est une erreur de ma part, n'y faites pas attention

EDIT2 : Il manquait une partie du code... Désolé, j'ai corrigé

screen4 screen3 screen2 screen1

Je vous joins un fichier fonctionnel.

Cordialement,

Benoit.

4filter-problem.xlsm (136.07 Ko)

Bonjour,

Ta procédure revisitée.

A tester !...

Cdlt.

5filter-problem.xlsm (140.40 Ko)
'----------------------------------------------------------------------------------------------------------
    strFilter = ComboBox1.value
    '----------------------------------------------------------------------------------------------------------
    Table1.Range.AutoFilter Field:=1, Criteria1:=strFilter

    Set rCell = Table3.InsertRowRange.Cells(1)

    With Table1.AutoFilter.Range
        On Error Resume Next
        Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With

    If Not rng2 Is Nothing Then
        Set rng = Table1.AutoFilter.Range
        rng.Offset(1, 0).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
        rCell.PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
    End If

    Table1.Range.AutoFilter Field:=1

    '----------------------------------------------------------------------------------------------------------
    Table2.Range.AutoFilter Field:=1, Criteria1:=strFilter
    Set rCell = Table4.InsertRowRange.Cells(1)

    With Table2.AutoFilter.Range
        On Error Resume Next
        Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1).SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
    End With

    If Not rng2 Is Nothing Then
        Set rng = Table2.AutoFilter.Range
        rng.Offset(1, 1).Resize(rng.Rows.Count, rng.Columns.Count - 1).SpecialCells(xlCellTypeVisible).Copy
        rCell.PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = False
    End If

    Table2.Range.AutoFilter Field:=1
    '----------------------------------------------------------------------------------------------------------

Cela fonctionne ! Merci !

Alors j'ai utilisé le mode pas à pas pour comprendre, mais je n'ai pas réussi... (Je ne maitrise pas tres bien VBA)

La chose qui m'interpelle le plus, c'est l'offcet. Pourquoi t'es-tu décalé d'une ligne au début ?

Encore merci

Re,

On ne copie pas les en-têtes de ligne!...

On doit donc décaler d'une ligne pour Table1.

Pour table2, on décale d'une ligne et d'une colonne…

Cdlt.

Ah... Suis-je bete...

Merci

Bonjour tout le monde

Ce message s'adresse principalement à ceux qui veulent récupérer le code plus tard.

Je viens de réaliser que lorsque je fais le test pour savoir si la Table4 est vide :

If Table4.DataBodyRange Is Nothing Then

    (Code)

Else

    (Code)

End If

Cela ne donne pas le résultat escompté. En effet, le .DataBodyRange ne sera pas égale à "rien" même si le tableau est vide. La fonction proposée par Jean-Eric semble copier une ligne vide. Donc, même s'il n'y a rien, Excel considère qu'il y a quelque chose (probablement un bug). J'ai trouvé une solution pour résoudre le problème :

If Table4.Range(2, 1) = "" Then     'On regarde la deuxième ligne car se trouve sur la 1ere les en-têtes

    (Code)

Else

    (Code)

End If

De mon côté ça marche

Bonjour,

Il n' a pas de raison que cela ne fonctionne pas.

Aurais-tu modifié quelque chose ?

For Each Table In ws2.ListObjects
        If Not Table.DataBodyRange Is Nothing Then
            Table.DataBodyRange.Delete
        End If
    Next Table

Cdlt.

Bonjour Jean-Eric,

J'ai juste changé le nom de toutes les variables afin qu'elles soient en concordance avec mon fichier originel et décalé les offcets du code des Table1/3 d'une colonne.

Le passage du code que tu viens d'envoyer et écrit légèrement différemment, mais cela revient au même (sauf erreur de ma part).

With Table3
    If Not .DataBodyRange Is Nothing Then
        .DataBodyRange.Delete
    End If
End With

With Table4
    If Not .DataBodyRange Is Nothing Then
        .DataBodyRange.Delete
    End If
End With

A part ça, j'ai fais en sorte de toucher le moins de choses possibles. C'est pourquoi je pense qu'il s'agit d'un bug d'excel (mais je peux encore me tromper).

Re,

Envoie ton fichier.

Cdlt.

Rechercher des sujets similaires à "filtre tout devient inefficace"