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é
Bonjour,
Ta procédure revisitée.
A tester !...
Cdlt.
'----------------------------------------------------------------------------------------------------------
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.