Dupliquer tableau en fonction d'un critere

Bonjour,

Je souhaiterais de l'aide sur un problème que je n'arrive pas à résoudre.

J'ai une base (Tableau nommé) dans Excel et par VBA je souhaiterais que ce tableau soit dupliqué en fonction des critères qui se trouve en colonne A et qui sont 4, 101, 22.

Quand je lance la macro je voudrais que le tableau soit copié avec les entêtes et la même mise en forme ainsi que la même largeur des colonnes dans des nouveaux onglets qui se nommeront 4, 101, 22.

Je vous met le fichier TEST ainsi que la macro que j'ai trouvé mais qui ne fonctionne pas, elle me créer les nouveaux onglets 4, 22, 101 mais les feuilles sont vides.

Merci d'avance

Sub CopierTableauSelonCritere()
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim critere As Variant
    Dim destSheetName As String

    ' Définir la feuille source (ajustez le nom si nécessaire)
    Set wsSource = ThisWorkbook.Sheets("BASE_FRS_ORIGINE_SANDRA")
    Set rng = wsSource.Range("A1").CurrentRegion ' Ajustez la plage si nécessaire

    ' Boucle à travers les critères
    For Each critere In Array(4, 101, 22)
        ' Créer ou référencer la feuille de destination
        destSheetName = CStr(critere)

        On Error Resume Next
        Set wsDest = ThisWorkbook.Sheets(destSheetName)
        On Error GoTo 0

        If wsDest Is Nothing Then
            Set wsDest = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            wsDest.Name = destSheetName
        End If

        ' Copier les lignes correspondant au critère
        For Each cell In rng.Columns(1).Cells
            If cell.Value = critere Then
                cell.EntireRow.Copy wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
        Next cell

        ' Réinitialiser la variable de la feuille de destination
        Set wsDest = Nothing
    Next critere
End Sub

Bonjour,

remplacez ceci:

For Each critere In Array(4, 101, 22)

par ceci:

For Each critere In Array("4", "101", "22")

Cdlt

Bonjour,

Merci cela à fonctionner mais je n'ai pas les entêtes ni la mise en forme ni la même largeurs des colonnes et mon fichier n'a pas répondu un peu avant que cela passe.

Merci déjà pour l'info

Bonjour

Ci joint ma solution

A+ François

Bonjour,

Cela fonctionne mais ce n' estpas ce que je veux en faite je voudrais uniquement le tableau avec la société 4 dans l'onglet 4, tableau avec socété 101 onglet et tableau société 22 onglet 22

Cordialmeent,

J'arrive trop tard, mais essayez quand même:

Sub CopierTableauSelonCritere()
    Dim wsSource As Worksheet, wsDest As Worksheet
    Dim tbl As ListObject
    Dim critere As Variant
    Dim Filtre As Boolean
    Dim NbCol As Long

    Application.ScreenUpdating = False
    Set wsSource = ThisWorkbook.Sheets("BASE_FRS_ORIGINE_SANDRA")
    Set tbl = wsSource.ListObjects("BASE_FRS_ORIGINE_SANDRA")

    ' Retirer le filtre s’il existe
    If wsSource.AutoFilterMode Then wsSource.AutoFilterMode = False

    For Each critere In Array("4", "101", "22")
        ' Appliquer le filtre
        tbl.Range.AutoFilter Field:=1, Criteria1:=critere

        ' Créer ou référencer la feuille de destination
        On Error Resume Next
        Set wsDest = ThisWorkbook.Sheets(critere)
        On Error GoTo 0

        If wsDest Is Nothing Then
            Set wsDest = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            wsDest.Name = destSheetName
        Else
            wsDest.Cells.Clear
        End If

        ' Copier les lignes filtrées visibles
        tbl.Range.SpecialCells(xlCellTypeVisible).Copy
        wsDest.Range("A1").PasteSpecial xlPasteValues

        'largeurs des colonnes
        NbCol = wsSource.ListObjects("BASE_FRS_ORIGINE_SANDRA").DataBodyRange.Columns.Count
        For i = 1 To NbCol
            wsDest.Columns(i).ColumnWidth = wsSource.Columns(i).ColumnWidth
        Next i

        'Formatage ligne des titres
        With Range(wsDest.Cells(1, "A"), wsDest.Cells(1, NbCol)).Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .Color = 12611584
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With Range(wsDest.Cells(1, "A"), wsDest.Cells(1, NbCol)).Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .Bold = True
        End With
        Set wsDest = Nothing
    Next critere

    ' Retirer le filtre à la fin
    wsSource.AutoFilterMode = False
End Sub

Bonjour,

Je rectifie le code de Fanfan38 est bon et cela fonctionne bien par contre j'ai un souci dans le test cela va vite mais dans ma base qui est beaucoup plus grande et bien cela rame mon excel ne répond pas 30 secondes et aprés cela passe

Cordialement,