filtres excel et formule vba

Version imprimable

15/09/2009, 20h19
phiphi_j

filtres excel et formule vba
bonjour, je cherche une formule en vba qui permet de trouver le nombre d'enregistrements obtenus quand des filtres automatiques sont activés dans une liste sous excel.

Sinon mon problème est que j'ai une liste à laquelle je fais subir différents filtres et je veux copier les enregistrements obtenus dans un autre onglet mais que, si il n'y en a pas, il ne se passe rien.
Je pensais avoir trouvé mais quand je mets ça
Code:

1 2 3 Range("A2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy
et qu'il n'y a aucun résultat de trouvé pour ma sélection de filtres, il me copie le contenu de la cellule A2.

Une proposition

Code:

1
2
3
4
5
6
Dim LastLig As Long
 
LastLig = Range("A65536").End(xlUp).Row
If LastLig > 1 Then
Range("A1:A" & LastLig).Copy Sheets("FeuilleOùCopier").Range("A3")
End If

Bonsoir,

Une autre proposition:
Code:

1 2 3 4 5 ActiveSheet.Range("$A$1").AutoFilter Field:=10, Criteria1:="=*b0?????05*" X = ActiveSheet.AutoFilter.Range.Columns(10).SpecialCells(xlCellTypeVisible).Cells.Count Range("A2:C21").SpecialCells(xlCellTypeVisible).Copy Destination:=Range("A24")
A adapter

J'ai eu ces morceaux de code sur le forum et je les ai adapté, cela fonctionne très bien pour compter le nombre de lignes filtrées ou pour les copier.

En adaptant à l'aide de la proposition de marc58
Code:

1 2 3 4 5 Dim LastLig As Long With Sheets("Feuille Source") LastLig = .Range("A65536").End(xlUp).Row If LastLig > 1 Then .Range("A2:D" & LastLig).SpecialCells(xlCellTypeVisible).Copy Sheets("Feuille Destination").Range("A3") End With
Adapter les noms des feuilles et les plages de copie et de destination

16/09/2009, 12h22
phiphi_j

j'ai essayé quelques unes des formules que vous m'avez donné mais ça ne fonctionne pas. Je pense que je dois oublier quelque chose. est-ce que quelqu'un pourrait essayer de me l'écrire en entier.

Le fichier où je fais des filtres s'appelle "table essai1.xls" et l'onglet "devis".
Les filtres sont sur différentes colonnes (I, J, K) en même temps et les résultats que je souhaite copier quand il y en a sont dans la colone A.

Le fichier où je dois copier ces données s'appelle "recap mensuel.xls" et l'onglet "R-04-09" et la copie doit se faire à partir de la cellule D304.
Merci

Citation:

Sinon mon problème est que j'ai une liste à laquelle je fais subir différents filtres et je veux copier les enregistrements obtenus dans un autre onglet mais que, si il n'y en a pas, il ne se passe rien.

Si tu veux des informations précises, tu dois préciser ce que tu veux
si tu ne veux pas essayer d'adapter, c'est facile d'écrire

Citation:

est-ce que quelqu'un pourrait essayer de me l'écrire en entier.

Si tu as la gentillesse de poster ce que tu as fais et où ça ne fonctionne pas (si cela ne t'est pas pénible :mouarf:)

dans ton cas
Code:

1 2 3 4 5 6 7 8 9 10 11 12 Dim LastLig As Long Dim Wbk as Workbook Dim stFichierComp as string stFichierComp="C\Mes Documents\recap mensuel.xls" ' à adapter set Wbk=Workbooks.Open(stFichierComp) With Sheets("devis") LastLig = .Range("A65536").End(xlUp).Row If LastLig > 1 Then .Range("A2:A" & LastLig).SpecialCells(xlCellTypeVisible).Copy Wbk.Sheets("R-04-09").Range("A3") 'Tu ne dis pas où copier End With Set Wbk=Nothing
ce code par exemple sur un bouton sur ta feuille devis du fichier table essai1.xls

16/09/2009, 14h16
Duddy

Bonjour,

Si j'ai bien lu, tu veux copier le résultat de trois filtres consécutifs dans une feuille du même fichier.

Pour réaliser cela, j'ai procédé comme suit (je n'ai pas de code entier)
J'ai filtré ma 1ère colonne:

Code:

ActiveSheet.Range("$A$1").AutoFilter Field:=10, Criteria1:="=*b0?????05*"

J'ai contrôlé le résultat :

Code:

If ActiveSheet.AutoFilter.Range.Columns(10).SpecialCells(xlCellTypeVisible).Cells.Count>1 then

et j'ai répété l'opération en imbriquant les conditions:

Ensuite, j'ai copié et collé:

Code:

ActiveSheet.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("tasheet").Range("tacellule")

Je répète que j'ai trouvé tout cela sur le forum en demandant une recherche sur filtre.

Bon courage

Je mets la formule complète que j'ai utilisé au départ et qui copie la cellule A2 quand il n'y a pas de résultat.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 Selection.AutoFilter Field:=12, Criteria1:="<>" Selection.AutoFilter Field:=10, Criteria1:="<>" Selection.AutoFilter Field:=11, Criteria1:=">=39904", Operator:= _ xlAnd, Criteria2:="<=39933" Selection.AutoFilter Field:=2, Criteria1:="FC" Range("A2").Select Range(Selection, Selection.End(xlDown)).Select Selection.Copy Windows("récapitulatifs_mensuels_annuels.xls").Activate Sheets("R-04-09").Select Range("h2").Select ActiveSheet.Paste Range("a1").Select
Voilà les deux types de formules que j'ai testé mais quand je le fais les filtres se font mais pas la copie dans l'autre fichier.
Code:

1 2 3 4 5 6 Windows("tables essai1.xls").Activate Sheets("devis").Select ActiveSheet.Range("$A$1").AutoFilter Field:=11, Criteria1:="=" X = ActiveSheet.AutoFilter.Range.Columns(11).SpecialCells(xlCellTypeVisible).Cells.Count Range("A2:a65536").SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("R-04-09").Range("d304")
Code:

1 2 3 4 5 6 7 8 9 10 11 Windows("tables essai1.xls").Activate Sheets("devis").Select Range("A1").Select Selection.AutoFilter Selection.AutoFilter Field:=11, Criteria1:="=" Selection.AutoFilter Field:=9, Criteria1:="<>" Dim LastLig As Long With Sheets("devis") LastLig = .Range("A65536").End(xlUp).Row If LastLig > 1 Then .Range("A" & LastLig).SpecialCells(xlCellTypeVisible).Copy Windows("récapitulatifs_mensuels_annuels").Sheets("R-04-09").Range("d304")
Les données que je dois copier se trouve uniquement dans la colonne A de "tables essai1".
Et je ne peux pas mettre de bouton pour effectuer cette manip parce que je dois répérer ce type d'opérations une bonne 50aine de fois. Ou alors il faudrait que je puisse mettre ce bouton dans le fichier "recap mensuel" dans lequel je dois copier les données obtenues.
Et sinon comme je suis débutante en VBA, elle sert à quoi la formule de mercatog qui peut être mise avec le bouton ?

16/09/2009, 14h49
phiphi_j

réponse à marc58

En fait je dois copier mes données dans un autre fichier, amis comme je n'avais pas bien lu ce que tu avais écrit je l'ai testé quand même. Elle bloque à

Code:

ActiveSheet.SpecialCells(xlCellTypeVisible).Copy Destination:=Sheets("R-04-09").Range("d304")

et me dit que l'indice n'appartient pas à la sélection. As-tu une suggestion ?
Il faudrait que je puisse rajouter que c'est dans le fichier"recap mens" que se trouve la feuille "R-04-09" et la cellule "D304"...
16/09/2009, 14h53
Duddy

Bonjour,

Code:

ActiveSheet.SpecialCells(xlCellTypeVisible).Copy Destination:=Workbooks("recap mens.xls").Sheets("R-04-09").Range("d304")

Sinon tu utilises l'enregistrement automatique, ainsi tu auras le code que tu veux.

Bon courage

Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 Dim LastLig As Long Dim Wbk as Workbook Dim stFichierComp as string stFichierComp="C\Mes Documents\recap mensuel.xls" ' à adapter set Wbk=Workbooks.Open(stFichierComp) With Sheets("devis") LastLig = .Range("A65536").End(xlUp).Row If LastLig > 1 Then .Range("A2:A" & LastLig).SpecialCells(xlCellTypeVisible).Copy Wbk.Sheets("R-04-09").Range("A3") 'Tu ne dis pas où copier End With Wbk.Save Xbk.Close Set Wbk=Nothing
permet de copier les donnée de A2 jusqu'à An de la feuille devis à partir de la cellule A3 de la feuille R-04-09 du fichier recap mensuel.xls que la procédure a ouvert.
j'ai compris que tu a des filtres, tu choisis les critère et tu voulais copier le résultat ailleurs!!

réponse à marc58

si je fais enregistrement automatique ça me donne ça

Code:

1
2
3
4
5
6
7
    Range("A2:A14").Select
    Selection.Copy
    Windows("récapitulatifs_mensuels_annuels.xls").Activate
    Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Windows("tables essai1.xls").Activate
    Application.CutCopyMode = False

et je ne sais pas comment l'adapter...

16/09/2009, 15h33
phiphi_j

réponse à mercatog

j'ai essayé ta formule mais il me dit que sheets("devis") n'appartient pas à la sélection...
16/09/2009, 15h49
Duddy

Bonjour,

Peux-tu essayer avec cela

Code:

ActiveSheet.SpecialCells(xlCellTypeVisible).Copy Destination:=Workbooks("récapitulatifs_mensuels_annuels.xls").Sheets("R-04-09").Range("d304")

Citation:

j'ai essayé ta formule mais il me dit que sheets("devis") n'appartient pas à la sélection...

Si tu lances le procédure à partir de ton classeur Facturation.xls
et si ta feuille s'appelle bien "devis"
et à mesure de changer à main levée sans tester,
voilà le résultat (en fait après l'ouverture du fichier Wbk, il devient le Classeur actif, d'où l'erreur)
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 Dim LastLig As Long Dim Wbk As Workbook, aWbk As Workbook Dim stFichierComp As String stFichierComp = "C\Mes Documents\recap mensuel.xls" ' à adapter Set aWbk = ThisWorkbook Set Wbk = Workbooks.Open(stFichierComp) With aWbk.Sheets("devis") LastLig = .Range("A65536").End(xlUp).Row If LastLig > 1 Then .Range("A2:A" & LastLig).SpecialCells(xlCellTypeVisible).Copy Wbk.Sheets("R-04-09").Range("A3") 'Tu ne dis pas où copier End With Wbk.Save Wbk.Close Set Wbk = Nothing Set aWbk = Nothing

Je suis déspérée !

J'ai testé ce que vous m'avez dit et voilà le résultat :

Code:

1
2
3
4
5
6
7
8
9
  Sub essai()
 
   ActiveSheet.Range("$A$1").AutoFilter Field:=11, Criteria1:="="
X = ActiveSheet.AutoFilter.Range.Columns(11).SpecialCells(xlCellTypeVisible).Cells.Count
 
 ActiveSheet.SpecialCells(xlCellTypeVisible).Copy Destination:=Workbooks("récapitulatifs_mensuels_annuels.xls").Sheets("R-04-09").Range("d304")
 
 
End Sub

Windows me dit que l'indice n'appartient pas à la sélection.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
  Sub essai()
 
    Selection.AutoFilter Field:=12, Criteria1:="<>"
    Selection.AutoFilter Field:=10, Criteria1:="<>"
 
  Dim LastLig As Long
Dim Wbk As Workbook, aWbk As Workbook
Dim stFichierComp As String
 
stFichierComp = "H:\récapitulatifs_mensuels_annuels.xls" ' à adapter
 
Set aWbk = ThisWorkbook
Set Wbk = Workbooks.Open(stFichierComp)
 
With aWbk.Sheets("devis")
    LastLig = .Range("A65536").End(xlUp).Row
    If LastLig > 1 Then .Range("A2:A" & LastLig).SpecialCells(xlCellTypeVisible).Copy Wbk.Sheets("R-04-09").Range("A3") 'Tu ne dis pas où copier
End With
 
Set Wbk = Nothing
Set aWbk = Nothing
 
End Sub

Le programme s'exécute sans bogage mais il n'y a rien de copié dans récap mens.

J'ai vraiment besoin que ça marche, au secours SVP !

Tu peux joindre ton fichier avec bien sûr peu de donnée, parce que j'ai testé sur un exemple personnel et ça fonctionne chez moi

ci joint mon exemple; j'ai mis mes critères du filtre

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Dim LastLig As Long
Dim Wbk As Workbook, aWbk As Workbook
Dim stFichierComp As String
Dim plage As Range
 
stFichierComp = "C:\Users\user\Desktop\DEVELOPPEZ\AAAAmine-mercredi-06-2002.xls" ' à adapter
 
Set aWbk = ThisWorkbook
Set Wbk = Workbooks.Open(stFichierComp)
 
 
With aWbk.Sheets("devis")
Set plage = .Range("A1:D" & .Range("A65536").End(xlUp).Row)
    plage.AutoFilter                                            'pour supprimer les filtres existants
    plage.AutoFilter Field:=4, Criteria1:="<>A"
    plage.AutoFilter Field:=3, Criteria1:="<>2000"
 
    LastLig = .Range("A65536").End(xlUp).Row
    If LastLig > 1 Then .Range("A2:A" & LastLig).SpecialCells(xlCellTypeVisible).Copy Wbk.Sheets("AAA").Range("A3") 'Tu ne dis pas où copier
End With
 
Set Wbk = Nothing
Set aWbk = Nothing

16/09/2009, 23h32
phiphi_j

2 pièce(s) jointe(s)

essai non concluant

voilà mon essai mais il me dit qu'il ne peut pas coller parce qu'il y a des différences de formats de cellules. En plus cet essai est fait sous Excel 2007 mais j'utilise Excel 2003 pour mon programme en réalité. C'est peut-être ce qui se passe sous Excel 2003 quand je lance mon programme à part qu'il ne me le dit pas..
17/09/2009, 01h04
mercatog

Ci-joint fichier facturation avec un exemple de filtre!
adapter dans le code du bouton le chemin complet du fichier récapitulatifs_mensuels_annuels.xls
17/09/2009, 09h32
phiphi_j

merci mais ...

Effectivement j'ai testé ta macro et ça marche mais est-ce que tu pourrais me dire comment faire pour que tout cela se fasse à partir du fichier "récap mens" et pas de "facturation".

Dans ta feuille R-04-09 du fichier récap mensuel, tu mets un bouton, tu lui colle ce code, le tour est joué

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
 
Dim LastLig As Long
Dim Wbk As Workbook, aWbk As Workbook
Dim stFichierComp As String
Dim plage As Range
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Cells.ClearContents                     'Ici efface d'abord toute ta feuille R-04-09, tu peux adapter à seulement ne certaine zone
 
stFichierComp = "C:\Documents and Settings\Administrateur\Bureau\FACTURATION.xls" ' !!!!!!à adapter
 
Set Wbk = ThisWorkbook
Set aWbk = Workbooks.Open(stFichierComp)
 
 
With aWbk.Sheets("devis")
Set plage = .Range("A1:C" & .Range("A65536").End(xlUp).Row)
    plage.AutoFilter                                            'pour supprimer les filtres existants
    plage.AutoFilter Field:=2, Criteria1:=">200"
    plage.AutoFilter Field:=3, Criteria1:="<300"
 
    LastLig = .Range("A65536").End(xlUp).Row
    If LastLig > 1 Then .Range("A2:C" & LastLig).SpecialCells(xlCellTypeVisible).Copy Wbk.Sheets("R-04-09").Range("A3") 'Tu ne dis pas où copier
End With
 
aWbk.Close
Set Wbk = Nothing
Set aWbk = Nothing
 
Application.DisplayAlerts = False
Application.ScreenUpdating = True

24/09/2009, 12h00
phiphi_j

Merci

Désolé de ne pas avoir donné de nouvelles plus tôt. Merci à mercatog pour sa formule qui a fonctionné. Merci beaucoup !:ccool: