Trier les données et les mettre dans un onglet

Bonjour,
J'aimerais réaliser une macro qui trie plusieurs onglets selon un critère, et qui colle dans un autre onglet le résultat obtenu.

J'ai fait un exemple en PJ.

L'idée serait de regarder dans chaque onglet et de ne trier que les lignes sans #N/A dans la colonne B.

Et de coller les lignes dans un autre onglet.

Pensez-vous pouvoir me guider, svp?

J'ai créé un onglet "objectif macro" pour que vous puissiez visualiser l'attendu que je rechercherais

J'ai commencé la macro, mais je bloque...

Sub Macro1()
'
' Macro1 Macro
'

'Sélection Onglet 1 des valeurs hors N/A
    Selection.AutoFilter
    ActiveSheet.ListObjects("Tableau1").Range.AutoFilter Field:=2, Criteria1:= _
        "<>#N/A", Operator:=xlOr

'Copie du filtre
Range("????").Select
    Selection.Copy
    Sheets("ONGLET CIBLE").Select
    Range("???").Select
    ActiveSheet.Paste

End Sub

Un grand merci pour vos avis!

Bonjour,
Une proposition.
Cdlt.

Public Sub CopyFilteredData()
Dim ws As Worksheet
Dim lo As ListObject, loResult As ListObject
Dim r As Range, rng As Range, rng2 As Range

    Application.ScreenUpdating = False

    Set loResult = Worksheets("Résultat").Range("t_résultat").ListObject

    With loResult
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        Set r = .InsertRowRange.Cells(1)
    End With

    For Each ws In ActiveWorkbook.Worksheets
        For Each lo In ws.ListObjects
            If lo.Name <> "t_résultat" Then
                With lo
                    If .ShowAutoFilter Then .AutoFilter.ShowAllData
                    .Range.AutoFilter field:=2, Criteria1:="<>#N/A"
                    With .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 = .AutoFilter.Range
                        rng.Offset(1, 0).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
                        r.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        Application.CutCopyMode = 0
                        Set r = loResult.HeaderRowRange.Cells(1).Offset(loResult.ListRows.Count + 1)
                    End If
                    .Range.AutoFilter field:=2
                End With
            End If
        Next lo
    Next ws

End Sub

Re,
Une autre proposition réalisée avec Power Query.
Cdlt.

Merci Jean-Eric.

Ca marche "impec" avec de faibles volumétrie de données.

Mais face à la réalité, j'ai des soucis de performance.

Du coup j'avais envisagé de, à chaque fois que je copie le contenu voulu d'un onglet X, de le supprimer dans la foulée.

Pour séquencer :

1) Je charge un onglet X et je le filtre

2) Je charge le contenu du filtre dans l'onglet "résultat"

3) Je supprime l'onglet X

4) Je charge un onglet Y et je le filtre

5) Je charge le contenu du filtre dans l'onglet "résultat" EN DESSOUS de ce que j'ai déjà chargé

6) Je supprime l'onglet Y

etc...

J'ai essayé de retoucher à la partie que tu m'as suggéré, mais je bloque.

Il s'agit de la partie en dessous "'Ajout dans l'onglet résultat 1".

Est-ce que tu aurais une suggestion pour m'aider?

Sub VACANCES_lot1()
'
'
'Déclarations
Dim ws As Worksheet
Dim lo As ListObject, loResult As ListObject
Dim r As Range, rng As Range, rng2 As Range

'Chargement fichier 1
    Application.ScreenUpdating = True 'interrompre l'actualisation de l'écran
    Worksheets("AG0101").ListObjects(1).QueryTable.Refresh (False)

' Ajout colonne sur chaque onglet 1
Set ws = Worksheets("AG0101") 'définit l'onglet O
ws.Select
    'Ajout colonne
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Cells.EntireColumn.AutoFit
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "=VLOOKUP([@[POS ID Group]],Posvac!C[-1],1,0)"

'Ajout dans l'onglet résultat 1 
    Application.ScreenUpdating = False

    Set loResult = Worksheets("Résultat").Range("t_résultat").ListObject

    With loResult
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        Set r = .InsertRowRange.Cells(1)
    End With

     Set ws = Worksheets("AG0101")
                With lo
                    If .ShowAutoFilter Then .AutoFilter.ShowAllData
                    .Range.AutoFilter Field:=2, Criteria1:="<>#N/A"
                    With .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 = .AutoFilter.Range
                        rng.Offset(1, 0).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
                        r.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        Application.CutCopyMode = 0
                        Set r = loResult.HeaderRowRange.Cells(1).Offset(loResult.ListRows.Count + 1)
                    End If
                    .Range.AutoFilter Field:=2
                End With

'  NETTOYAGE 1
'Nettoyage Résultat
Set ws = Worksheets("Résultat") 'définit l'onglet 
ws.Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("B:B").Select
    Selection.Delete Shift:=xlToLeft
'Suppression onglets
    Application.DisplayAlerts = False
    Sheets("AG0101").Select
    Sheets("AG0101").Activate
    Application.CutCopyMode = False
    ActiveWindow.SelectedSheets.Delete
    Application.DisplayAlerts = True

End Sub

Un grand merci pour ton aide!

Re,
J'ai modifié la procédure VBA pour supprimer les feuilles après copie des données.
Cdlt.

Bonjour.

Ca fonctionne très bien mais....j'ai encore le problème de lourdeur de données.

J'ai une idée en tête, mais pour cela, j'aurais besoin besoin de faire fonctionner le VBA ci-dessous y compris avec des données qui ne sont PAS dans un tableau.

Car le tableau alourdi le tout...Est-ce que c'est envisageable?

On colle un "non tableau" dans un "tableau" (celui de l'onglet résultat)

Option Explicit

Public Sub CopyFilteredData()
Dim ws As Worksheet
Dim lo As ListObject, loResult As ListObject
Dim r As Range, rng As Range, rng2 As Range

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Set loResult = Worksheets("Résultat").Range("t_résultat").ListObject

    With loResult
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        Set r = .InsertRowRange.Cells(1)
    End With

    For Each ws In ActiveWorkbook.Worksheets
        For Each lo In ws.ListObjects
            If lo.Name <> "t_résultat" Then
                With lo
                    If .ShowAutoFilter Then .AutoFilter.ShowAllData
                    .Range.AutoFilter field:=2, Criteria1:="<>#N/A"
                    With .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 = .AutoFilter.Range
                        rng.Offset(1, 0).Resize(rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
                        r.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                        Application.CutCopyMode = 0
                        Set r = loResult.HeaderRowRange.Cells(1).Offset(loResult.ListRows.Count + 1)
                    End If
                    .Range.AutoFilter field:=2
                    Worksheets(lo.Parent.Name).Delete
                End With
            End If
        Next lo
    Next ws

End Sub

RE.

C'est clairement pas propre, mais je vais tenter de copier sans le tableau et de remettre le tableau ensuite.

Bref, svp, ne perdez pas votre temps avec mon post précédent, je vais tenter quelque chose.

' Macro6 Macro
'

'
    Range("A1:C4").Select
    Range("B3").Activate
    Application.CutCopyMode = False
    ActiveSheet.ListObjects.Add(xlSrcRange, Range(Selection, Selection.End(xlToRight)), , xlYes).Name = _
        "Tableau1"
    Range("Tableau1[#All]").Select
    ActiveSheet.ListObjects("Tableau1").TableStyle = "TableStyleMedium9"
End Sub