Discussion :

[phiphi_j]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

[mercatog]

Une proposition

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Duddy]

Bonsoir,

Une autre proposition:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

[mercatog]

En adaptant à l'aide de la proposition de marc58

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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

[mercatog]

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

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 )

dans ton cas

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[phiphi_j]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 ?

[phiphi_j]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

 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"...

[Duddy]

Bonjour,

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 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

[mercatog]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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!!

[phiphi_j]

si je fais enregistrement automatique ça me donne ça

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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...

[phiphi_j]

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

[Duddy]

Bonjour,

Peux-tu essayer avec cela

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[mercatog]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[phiphi_j]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 !

[mercatog]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[phiphi_j]

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..

[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

[phiphi_j]

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".