XL 2016 Copier une feuille avec une condition de valeur dans une colonne

[Dadi147]

Copier une feuille Excel avec une condition de valeur dans une colonne et filtrer les données dans un tableau

 

[JHA]

Bonjour à tous,

On peut filtrer avec Power Query ou filtre avancé ou autre.
Un essai avec Power Query.

Edit: Bonjour Job75 😉

JHA

 

[job75]

Voyez le fichier joint et cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim choix As Range, deb As Range, nom$, w As Worksheet, i&, x$, j&
Set choix = [C5] 'à adapter éventuellement
Set deb = [A18] 'à adapter éventuellement
nom = CStr(choix)
If Intersect(Target, choix) Is Nothing Or nom = "" Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
Set w = Sheets(nom)
On Error GoTo 0
'---création de la feuille---
If w Is Nothing Then
    Me.Move Before:=Sheets(1)
    Set w = Sheets.Add(After:=Me)
    w.Name = nom
    For i = 2 To Sheets.Count - 1
        x = Sheets(i).Name
        For j = i + 1 To Sheets.Count
            If Sheets(j).Name < x Then Sheets(j).Move Before:=Sheets(i) 'classement
    Next j, i
End If
'---copies---
Cells.Copy w.[A1] 'copier-coller
w.Range(choix(1, 0).Address).Resize(, 2).Clear
w.Range(deb.Address).CurrentRegion.Clear
choix(0) = "NAME"
deb.CurrentRegion.AdvancedFilter xlFilterCopy, choix(0).Resize(2), w.Range(deb.Address) 'copie le filtre avancé
choix(0) = ""
With w.UsedRange: End With 'actualise la barre de défilement verticale
w.Activate
End Sub

Edit : bonjour JHA.

 

[Dadi147]

Voyez le fichier joint et cette macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim choix As Range, deb As Range, nom$, w As Worksheet, i&, x$, j&
Set choix = [C5] 'à adapter éventuellement
Set deb = [A18] 'à adapter éventuellement
nom = CStr(choix)
If Intersect(Target, choix) Is Nothing Or nom = "" Then Exit Sub
Application.ScreenUpdating = False
On Error Resume Next
Set w = Sheets(nom)
On Error GoTo 0
'---création de la feuille---
If w Is Nothing Then
    Me.Move Before:=Sheets(1)
    Set w = Sheets.Add(After:=Me)
    w.Name = nom
    For i = 2 To Sheets.Count - 1
        x = Sheets(i).Name
        For j = i + 1 To Sheets.Count
            If Sheets(j).Name < x Then Sheets(j).Move Before:=Sheets(i) 'classement
    Next j, i
End If
'---copies---
Cells.Copy w.[A1] 'copier-coller
w.Range(choix(1, 0).Address).Resize(, 2).Clear
w.Range(deb.Address).CurrentRegion.Clear
choix(0) = "NAME"
deb.CurrentRegion.AdvancedFilter xlFilterCopy, choix(0).Resize(2), w.Range(deb.Address) 'copie le filtre avancé
choix(0) = ""
With w.UsedRange: End With 'actualise la barre de défilement verticale
w.Activate
End Sub

Edit : bonjour JHA.

Merci pour votre aide. Le problème est que lorsque je copie le code dans le fichier d'origine, j'obtiens un message d'erreur malgré le changement de numéro de cellule

J'avais précédemment essayé de créer un code, mais je n'ai pas réussi à copier les données sur chaque feuille

 

[job75]

Le problème est que lorsque je copie le code dans le fichier d'origine, j'obtiens un message d'erreur

C'est à vous d'adapter, j'en ai assez fait.

 

[Dadi147]

Y-a-t'il une solution ?

 

[job75]

J'espère que vous vous rendez compte que votre fichier est bien différent de celui du post #1.

Les cellules fusionnées du tableau A30:S34 posaient problème mais je m'en suis sorti en copiant les formats de la 1ère ligne vers le bas.

Par ailleurs j'ai ajouté ce code dans ThisWorkbook :

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim feuille
feuille = Array("AA", "AB", "C", "D") 'liste des feuilles à traiter
If IsNumeric(Application.Match(Sh.Name, feuille, 0)) Then Sheets("main").[B27] = Sh.Name 'lance la macro Worksheet_Change
End Sub

pour que les feuilles se mettent à jour quand on les active.