Filtre avec répétition de lignes en haut (vba)

Le
j-pascal
Bonsoir,

Dans le code qui suit (que je dois à MichDenis), seules les valeurs
situées sur les lignes 16 et plus sont fitrées

J'avais renoncé à exporter quelques lignes situées au dessus de ce
tableau mais finalement ça me fait défaut.

J'ai donc tenté de modifier le code pour exporter les valeurs
récurentes situées sur les lignes 10 à 14 ! Sans succès !!

Précision : ces 5 lignes seraient répétées comme dans "MiseEnPage /
Feuille / Lignes à répéter en haut".

Y-a-t-il peu de choses à changer dans le présent code pour que je
parvienne à mon but ?


'
With ActiveSheet
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With

Set Sh = Worksheets.Add

On Error Resume Next

With Rg
.AdvancedFilter xlFilterCopy, , Sh.Range("A1"), True
Worksheets(.Parent.Name).ShowAllData
End With

With Sh
Set Rg1 = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With

For Each C In Rg1
Set Sh1 = Worksheets.Add(after:=Sheets(Sheets.Count))
Sh1.Name = C.Value
With Rg
.AutoFilter field:=1, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sh1.Range("A1")

Sh1.Range("A1").Range("A1").CurrentRegion.EntireColumn.AutoFit
End With
'

Merci pour votre aide,

JP
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses Page 1 / 2
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
j-pascal
Le #19208011
Bonjour Denis,

Je redoutais de m'être mal exprimé ...

Actuellement, la ligne qui sert de référence au filtre est la n° 15.
Toutes les lignes inférieures sont donc filtrées.

Sur mon classeur d'origine, de la ligne 1 à 14, j'ai des données :

Numéro de la semaine,
Message au destinataire,
Nom du fichier extrait,
etc.

(Actuellement) les classeurs exportés replacent la ligne 15 (de titre)
du classeur d'origine à la ligne 1 du nouveau classeur (ou plutôt de la
nouvelle feuille).

J'aimerais que les lignes 10 à 14 (ie) du classeur d'origine soient
systématiquement copiées dans les nouvelles feuilles créées et que la
ligne de titre commence (donc) à la ligne 6 (ie).

En fait, ces données "communes" sont nécessaires aux destinataires des
classeurs. Si c'est possible, je préfère qu'elles fassent partie des
classeurs (feuilles) créés plutôt que d'avoir à les recopier dans un
autre fichier ou dans le corps d'un mail (ie).

Dans ce cas, l'adaptation de ton code est pour moi impossible.

Si ce n'est toujours pas clair, dis moi.

JP

Bonjour J-Pascal,

Je n'ai pas vraiment compris ce que tu désires faire, mais si tu veux
que le filtre débute à la ligne 10 plutôt qu'à la ligne 15

Tu n'a qu'à modifier cette ligne de code :
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)


Pour
Set Rg = .Range("B10:B" & .Range("b65536").End(xlUp).Row)

Change la valeur 15 pour la valeur 10.




"j-pascal" discussion : Bonsoir,

Dans le code qui suit (que je dois à MichDenis), seules les valeurs
situées sur les lignes 16 et plus sont fitrées ...

J'avais renoncé à exporter quelques lignes situées au dessus de ce
tableau mais finalement ça me fait défaut.

J'ai donc tenté de modifier le code pour exporter les valeurs
récurentes situées sur les lignes 10 à 14 ! Sans succès !!

Précision : ces 5 lignes seraient répétées comme dans "MiseEnPage /
Feuille / Lignes à répéter en haut".

Y-a-t-il peu de choses à changer dans le présent code pour que je
parvienne à mon but ?


'---------------------------
With ActiveSheet
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With

Set Sh = Worksheets.Add

On Error Resume Next

With Rg
.AdvancedFilter xlFilterCopy, , Sh.Range("A1"), True
Worksheets(.Parent.Name).ShowAllData
End With

With Sh
Set Rg1 = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With

For Each C In Rg1
Set Sh1 = Worksheets.Add(after:=Sheets(Sheets.Count))
Sh1.Name = C.Value
With Rg
.AutoFilter field:=1, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sh1.Range("A1")

Sh1.Range("A1").Range("A1").CurrentRegion.EntireColumn.AutoFit
End With
'---------------------------

Merci pour votre aide,

JP


j-pascal
Le #19209851
Hum,

Tout ce que tu as fait est parfait. Mais en plus, j'aimerais que les
lignes 10 à 14 du classeur initial (celui qui contient toutes les
données qui seront ensuite filtrées) soient copiées dans tous les
classeurs créés (car elles sont identiques pour tous les
destinataires).

Dans ce cas, ton tableau (exporté) serait décalé de 5 lignes vers le
bas et de la ligne 1 à 5, j'aurais le contenu des lignes 1 à 14 du
tableau de départ.

Il n'y a aucune "intervention" à faire sur les lignes copiées, il
suffit (!) de laisser quelques lignes au dessus des feuilles créés pour
y copier le contenu d'autres lignes.

Pour être plus précis :

Les numéros à gauche sont les références de lignes :

1) Tableau initial (celui qui contient toutes les données, non
filtrées)

1 blabla
2 blabla
3
4
5
6
7
8
9
10 Cette valeur m'intéresse ...
11 Celle-ci aussi !
12 Celle-ci aussi !
13 Celle-ci aussi !
14 Celle-ci aussi !
15 Les titres de mon tableau : N° Cde / Fourn. / Art. / etc
15 Mes données non filtrées
17 Mes données non filtrées
18 Mes données non filtrées
19 etc.

2) Un des exports réalisé actuellement(classeur pour N°Cde "toto 1")

1 Les titres de mon tableau : N°Cde / Fourn. / Art. / etc
2 données filtrées concernant le N°de "toto 1"
3 données filtrées concernant le N°Cde "toto 1"
4 données filtrées concernant le N°Cde "toto 1"
5 etc.

9) Le tableau que je souhaiterais :

1 Cette valeur m'intéresse ...
2 Celle-ci aussi !
3 Celle-ci aussi !
4 Celle-ci aussi !
5 Celle-ci aussi !
6 Les titres de mon tableau : N°Cde / Fourn. / Art. / etc
7 données filtrées concernant le N°Cde "toto 1"
8 données filtrées concernant le N°Cde "toto 1"
9 données filtrées concernant le N°Cde "toto 1"
10 etc.


NB : et pour "toto 2"

1 Cette valeur m'intéresse ...
2 Celle-ci aussi !
3 Celle-ci aussi !
4 Celle-ci aussi !
5 Celle-ci aussi !
6 Les titres de mon tableau : N° Cde / Fourn. / Art. / etc
7 données filtrées concernant le N°Cde "toto 2"
8 données filtrées concernant le N°Cde "toto 2"
9 données filtrées concernant le N°Cde "toto 2"
10 etc.

@ + ?

jp







Actuellement, la ligne qui sert de référence au filtre est la n° 15.
Toutes les lignes inférieures sont donc filtrées.



Je n'ai rien compris !

Tu exécutes un filtre automatique ? Si tu veux modifier la plage
sur laquelle s'exerce le filtre, mon message précédent t'indique
comment faire.




"j-pascal" discussion : Bonjour Denis,

Je redoutais de m'être mal exprimé ...

Actuellement, la ligne qui sert de référence au filtre est la n° 15.
Toutes les lignes inférieures sont donc filtrées.

Sur mon classeur d'origine, de la ligne 1 à 14, j'ai des données :

Numéro de la semaine,
Message au destinataire,
Nom du fichier extrait,
etc.

(Actuellement) les classeurs exportés replacent la ligne 15 (de titre)
du classeur d'origine à la ligne 1 du nouveau classeur (ou plutôt de la
nouvelle feuille).

J'aimerais que les lignes 10 à 14 (ie) du classeur d'origine soient
systématiquement copiées dans les nouvelles feuilles créées et que la
ligne de titre commence (donc) à la ligne 6 (ie).

En fait, ces données "communes" sont nécessaires aux destinataires des
classeurs. Si c'est possible, je préfère qu'elles fassent partie des
classeurs (feuilles) créés plutôt que d'avoir à les recopier dans un
autre fichier ou dans le corps d'un mail (ie).

Dans ce cas, l'adaptation de ton code est pour moi impossible.

Si ce n'est toujours pas clair, dis moi.

JP

Bonjour J-Pascal,

Je n'ai pas vraiment compris ce que tu désires faire, mais si tu veux
que le filtre débute à la ligne 10 plutôt qu'à la ligne 15

Tu n'a qu'à modifier cette ligne de code :
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)


Pour
Set Rg = .Range("B10:B" & .Range("b65536").End(xlUp).Row)

Change la valeur 15 pour la valeur 10.




"j-pascal" discussion : Bonsoir,

Dans le code qui suit (que je dois à MichDenis), seules les valeurs
situées sur les lignes 16 et plus sont fitrées ...

J'avais renoncé à exporter quelques lignes situées au dessus de ce
tableau mais finalement ça me fait défaut.

J'ai donc tenté de modifier le code pour exporter les valeurs
récurentes situées sur les lignes 10 à 14 ! Sans succès !!

Précision : ces 5 lignes seraient répétées comme dans "MiseEnPage /
Feuille / Lignes à répéter en haut".

Y-a-t-il peu de choses à changer dans le présent code pour que je
parvienne à mon but ?


'---------------------------
With ActiveSheet
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With

Set Sh = Worksheets.Add

On Error Resume Next

With Rg
.AdvancedFilter xlFilterCopy, , Sh.Range("A1"), True
Worksheets(.Parent.Name).ShowAllData
End With

With Sh
Set Rg1 = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With

For Each C In Rg1
Set Sh1 = Worksheets.Add(after:=Sheets(Sheets.Count))
Sh1.Name = C.Value
With Rg
.AutoFilter field:=1, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sh1.Range("A1")

Sh1.Range("A1").Range("A1").CurrentRegion.EntireColumn.AutoFit
End With
'---------------------------

Merci pour votre aide,

JP




j-pascal
Le #19214371
Bonsoir Denis,

Je te remercie pour ta patience.

Dans :

With ActiveSheet
PlgACopier = .Range("A1:A5").EntireRow
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With



j'ai un pb avec : "PlgACopier = .Range("A1:A5").EntireRow"

Cette ligne n'est pas prise en compte et j'ignore vraiment pourquoi !
Si je mets "On error resume next" juste avant cette ligne, je passe à
la suivante (Set Reg ...), sinon ça me fait sortir de la procédure !

Ca fait un moment que je cherche, mais je ne trouve pas !

Je continue ...

JP

PS : sinon, j'imagine que cette solution répond parfaitement à mes
attentes.
MichDenis
Le #19214501
Il manque un petit mot "Set"

set PlgACopier = .Range("A1:A5").EntireRow



"j-pascal" Bonsoir Denis,

Je te remercie pour ta patience.

Dans :

With ActiveSheet
PlgACopier = .Range("A1:A5").EntireRow
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With



j'ai un pb avec : "PlgACopier = .Range("A1:A5").EntireRow"

Cette ligne n'est pas prise en compte et j'ignore vraiment pourquoi !
Si je mets "On error resume next" juste avant cette ligne, je passe à
la suivante (Set Reg ...), sinon ça me fait sortir de la procédure !

Ca fait un moment que je cherche, mais je ne trouve pas !

Je continue ...

JP

PS : sinon, j'imagine que cette solution répond parfaitement à mes
attentes.
j-pascal
Le #19214581
Suis complètement perdu !!

Voilà mes modifs, et pourtant ça ne copie pas les fameuses lignes ! :

'----------
Sub Export_Relances()
Dim Rg As Range, Rg1 As Range, C As Range
Dim Sh As Worksheet, Sh1 As Worksheet, Chemin As String
Dim Plage_Infos_Communes As Range 'ajout 28/04

Chemin = Path_Bureau & ""

If Dir(Chemin, vbDirectory) = "" Then
MsgBox "Le "" & chemin & "" & Inexistant.", vbCritical +
vbOKOnly, "Attention"
Exit Sub
End If

Chemin = Chemin & Format(Now, "yyyy-mm-dd HH`MM`SS")
MkDir Chemin
Stop
'Application.ScreenUpdating = False '28/04
On Error Resume Next
With ActiveSheet
Set Plage_Infos_Communes = .Range("A8:A12").EntireRow 'à
ajuster
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With

Set Sh = Worksheets.Add

On Error Resume Next

With Rg
.AdvancedFilter xlFilterCopy, , Sh.Range("A1"), True
Worksheets(.Parent.Name).ShowAllData
End With

With Sh
Set Rg1 = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With

For Each C In Rg1
Set Sh1 = Worksheets.Add(after:=Sheets(Sheets.Count))
Sh1.Name = C.Value
Plage_Infos_Communes.Copy Sh.Range("A1") 'erreur plus haut ??

With Rg
.AutoFilter field:=1, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sh1.Range("A6")

'Sh1.Range("A1").Range("A1").CurrentRegion.EntireColumn.AutoFit
'attention col.
End With
Sh1.Copy
With ActiveWorkbook
If Val(Application.Version) > 11 Then
.SaveAs Chemin & "" & C.Value & ".xlsm"
Else
.SaveAs Chemin & "" & C.Value & ".xls"
End If
.Close False
End With
Application.DisplayAlerts = False
Sh1.Delete
Application.DisplayAlerts = True
Next

Rg.AutoFilter
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End Sub
'----------

jp

Il manque un petit mot "Set"

set PlgACopier = .Range("A1:A5").EntireRow



"j-pascal" discussion : Bonsoir Denis,

Je te remercie pour ta patience.

Dans :

With ActiveSheet
PlgACopier = .Range("A1:A5").EntireRow
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With



j'ai un pb avec : "PlgACopier = .Range("A1:A5").EntireRow"

Cette ligne n'est pas prise en compte et j'ignore vraiment pourquoi !
Si je mets "On error resume next" juste avant cette ligne, je passe à
la suivante (Set Reg ...), sinon ça me fait sortir de la procédure !

Ca fait un moment que je cherche, mais je ne trouve pas !

Je continue ...

JP

PS : sinon, j'imagine que cette solution répond parfaitement à mes
attentes.


j-pascal
Le #19215281
Merci beaucoup +++++

Ce qui est étrange, c'est qu'aucune largeur de colonne n'est ajusté
(sauf la colonne A)!

'---
Sh1.Range("A1").Range("A1").CurrentRegion.EntireColumn.AutoFit
'---

J'avais shunté cette précédente ligne dans le code que je t'avais
envoyé, car il faudra que j'adapte "manuellement" la largeur de la
colonne A (le contenu des lignes 8 à 12 est plus long que le colonne A
filtrée).

Encore un très grand merci !

JP

Sub Export_Relances()
Dim Rg As Range, Rg1 As Range, C As Range
Dim Sh As Worksheet, Sh1 As Worksheet, Chemin As String
Dim Plage_Infos_Communes As Range, Nom As String

Chemin = Path_Bureau & ""

If Dir(Chemin, vbDirectory) = "" Then
MsgBox "Le "" & chemin & "" & Inexistant.", _
vbCritical + vbOKOnly, "Attention"
Exit Sub
End If

Chemin = Chemin & Format(Now, "yyyy-mm-dd HH`MM`SS")
MkDir Chemin

Application.ScreenUpdating = False
On Error Resume Next
With ActiveSheet
Nom = .Name
'àajuster
Set Plage_Infos_Communes = .Range("A8:A12").EntireRow
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With

Set Sh = Worksheets.Add

With Rg
.AdvancedFilter xlFilterCopy, , Sh.Range("A1"), True
End With

With Sh
Set Rg1 = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With

For Each C In Rg1
Set Sh1 = Worksheets.Add(after:=Sheets(Sheets.Count))
Sh1.Name = C.Value
Plage_Infos_Communes.Copy Sh1.Range("A1") 'erreur plus haut ??
With Rg
.AutoFilter field:=1, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).EntireRow.Copy _
Sh1.Range("A6")
Sh1.Range("A1").Range("A1").CurrentRegion.EntireColumn.AutoFit
End With
Sh1.Copy
With ActiveWorkbook
If Val(Application.Version) > 11 Then
.SaveAs Chemin & "" & C.Value & ".xlsx"
Else
.SaveAs Chemin & "" & C.Value & ".xls"
End If
.Close False
End With
Application.DisplayAlerts = False
Sh1.Delete
Application.DisplayAlerts = True
Next
Rg.AutoFilter
Application.DisplayAlerts = False
Sh.Delete
Sheets(Nom).Select
Application.DisplayAlerts = True
Application.ScreenUpdating = False
End Sub




"j-pascal" discussion : Suis complètement perdu
!!

Voilà mes modifs, et pourtant ça ne copie pas les fameuses lignes ! :

'----------
Sub Export_Relances()
Dim Rg As Range, Rg1 As Range, C As Range
Dim Sh As Worksheet, Sh1 As Worksheet, Chemin As String
Dim Plage_Infos_Communes As Range 'ajout 28/04

Chemin = Path_Bureau & ""

If Dir(Chemin, vbDirectory) = "" Then
MsgBox "Le "" & chemin & "" & Inexistant.", vbCritical +
vbOKOnly, "Attention"
Exit Sub
End If

Chemin = Chemin & Format(Now, "yyyy-mm-dd HH`MM`SS")
MkDir Chemin
Stop
'Application.ScreenUpdating = False '28/04
On Error Resume Next
With ActiveSheet
Set Plage_Infos_Communes = .Range("A8:A12").EntireRow 'à
ajuster
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With

Set Sh = Worksheets.Add

On Error Resume Next

With Rg
.AdvancedFilter xlFilterCopy, , Sh.Range("A1"), True
Worksheets(.Parent.Name).ShowAllData
End With

With Sh
Set Rg1 = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With

For Each C In Rg1
Set Sh1 = Worksheets.Add(after:=Sheets(Sheets.Count))
Sh1.Name = C.Value
Plage_Infos_Communes.Copy Sh.Range("A1") 'erreur plus haut ??

With Rg
.AutoFilter field:=1, Criteria1:=C.Value
.SpecialCells(xlCellTypeVisible).EntireRow.Copy
Sh1.Range("A6")

'Sh1.Range("A1").Range("A1").CurrentRegion.EntireColumn.AutoFit
'attention col.
End With
Sh1.Copy
With ActiveWorkbook
If Val(Application.Version) > 11 Then
.SaveAs Chemin & "" & C.Value & ".xlsm"
Else
.SaveAs Chemin & "" & C.Value & ".xls"
End If
.Close False
End With
Application.DisplayAlerts = False
Sh1.Delete
Application.DisplayAlerts = True
Next

Rg.AutoFilter
Application.DisplayAlerts = False
Sh.Delete
Application.DisplayAlerts = True
End Sub
'----------

jp

Il manque un petit mot "Set"

set PlgACopier = .Range("A1:A5").EntireRow



"j-pascal" discussion : Bonsoir Denis,

Je te remercie pour ta patience.

Dans :

With ActiveSheet
PlgACopier = .Range("A1:A5").EntireRow
Set Rg = .Range("B15:B" & .Range("b65536").End(xlUp).Row)
End With



j'ai un pb avec : "PlgACopier = .Range("A1:A5").EntireRow"

Cette ligne n'est pas prise en compte et j'ignore vraiment pourquoi !
Si je mets "On error resume next" juste avant cette ligne, je passe à
la suivante (Set Reg ...), sinon ça me fait sortir de la procédure !

Ca fait un moment que je cherche, mais je ne trouve pas !

Je continue ...

JP

PS : sinon, j'imagine que cette solution répond parfaitement à mes
attentes.




j-pascal
Le #19215271
Oups, je viens peut-être de comprendre, je n'ai pas de valeur en "A1"
et on est en "CurrentRegion" !

Je vais essayer de corriger ça ...

jp
j-pascal
Le #19215511
C'était bien ça !

Sachant que "A6" est le début de mon tableau filtré, j'ai donc adapté
comme ceci :

'--
Sh1.Range("A6").Range("A6").CurrentRegion.EntireColumn.AutoFit
'--

Je ne comprends pas pourquoi on a deux fois "Range("A6")" !



Mais plutôt que de passer par un ".CurrentRegion.EntireColumn.AutoFit",
est-il possible de copier dans le classeur (Feuille) de destination,
les mêmes largeurs de colonnes que celles du tableau de référence ?

jp
MichDenis
Le #19215871
| Sh1.Range("A6").Range("A6").CurrentRegion.EntireColumn.AutoFit

Tu n'as pas besoin de ma permission pour supprimer un des "Range("A6")

Do you ?





"j-pascal" C'était bien ça !

Sachant que "A6" est le début de mon tableau filtré, j'ai donc adapté
comme ceci :

'--
Sh1.Range("A6").Range("A6").CurrentRegion.EntireColumn.AutoFit
'--

Je ne comprends pas pourquoi on a deux fois "Range("A6")" !



Mais plutôt que de passer par un ".CurrentRegion.EntireColumn.AutoFit",
est-il possible de copier dans le classeur (Feuille) de destination,
les mêmes largeurs de colonnes que celles du tableau de référence ?

jp
j-pascal
Le #19216781
Bonjour Denis,

Tu veux dire qu'il s'agit d'une erreur ? Ok, je corrige.

J'ai trouvé un truc pour recopier la largeur des colonnes, mais (outre
qu'il faudrait que je l'adapte à ce code !), je crains que ça ne
ralentisse "sensiblement" le déroulement du code, car ça s'appliquerait
à une quarantaine de classeurs créés.

Peux-tu juste me dire (si tu veux bien !) ce que tu en pense sur le
principe ?

'--------
Sub LargCol()

x = Sheets("Feuil1").Columns.Count
For i = 1 To x
lg = Sheets("Feuil1").Columns(i).ColumnWidth
For Each F In ActiveWorkbook.Worksheets
If F.Name <> "Feuil1" Then F.Columns(i).ColumnWidth = lg
Next
Next
End Sub
'--------

jp

Sh1.Range("A6").Range("A6").CurrentRegion.EntireColumn.AutoFit



Tu n'as pas besoin de ma permission pour supprimer un des "Range("A6")

Do you ?





"j-pascal" discussion : C'était bien ça !

Sachant que "A6" est le début de mon tableau filtré, j'ai donc adapté
comme ceci :

'--
Sh1.Range("A6").Range("A6").CurrentRegion.EntireColumn.AutoFit
'--

Je ne comprends pas pourquoi on a deux fois "Range("A6")" !



Mais plutôt que de passer par un ".CurrentRegion.EntireColumn.AutoFit",
est-il possible de copier dans le classeur (Feuille) de destination,
les mêmes largeurs de colonnes que celles du tableau de référence ?

jp


Publicité
Poster une réponse
Anonyme