Scinder tableau Excel à partir d'une variable

Bonjour,

Je recherche une macro permettant de scinder un tableau à partir des données se trouvant dans une des colonnes.

Par exemple :

Colonne2CodeFournisseur

02456

02125

11235

02456

01254

Je souhaite avoir donc 4 tableaux puisque j'ai 4 données différentes. L'idée serait de pouvoir aussi l'adapter à d'autres données se trouvant dans une autre colonne et donc pouvoir également choisir d'effectuer le tri à partir des données de la colonne 3 par exemple, TypeProduit SF ; F ; E.

Je vous remercie d'avance pour votre aide !

Bonjour ManonB,

Merci de préciser ce que tu entends par "scinder" : tu voudrais que les tableaux issus des sélections soient créés dans une feuille spécifique du même classeur ou bien ?

Bonjour Gérard,

En effet je n'ai pas été très précise, je souhaite que ces tableaux soient créés dans des nouvelles feuilles du même classeur

Donc, une feuille par tableau ?

Bonjour ManonD,

Aurais-tu un échantillon de ton classeur initial ?

Bonjour Gérard,

Une feuille par tableau oui exactement.

Je vous joins un fichier en exemple, en colonne D se trouve le critère qui sera le plus souvent utilisé. Cependant, nous pourrions parfois avoir besoin de scinder le fichier à partir de la colonne A. Pour avoir le choix de la variable peut-être faudrait-il créer une feuille 1 dans laquelle serait indiqué le critère?

Je vous remercie!

Bonsoir ManonD,

Je te propose le code suivant :

Option Explicit
Sub Splitter()
    Dim oSheetFrom As Worksheet, oSheetTO As Worksheet
    Dim oCell As Range, oRange As Range

    Dim sColonne As String
    Dim aSheets As New Collection
    Dim elSheet As Variant

    sColonne = ThisWorkbook.Names("Colonne_Rupture").RefersToRange.Value

    If Not IsEmpty(sColonne) Then
        'On supprime toutes feuilles de split précedemment créées
        Application.DisplayAlerts = False
        For Each oSheetFrom In ThisWorkbook.Worksheets
            If Left(oSheetFrom.Name, 1) = "_" Then
                oSheetFrom.Delete
            End If
        Next
        Application.DisplayAlerts = True
        'On constitue la collection des feuilles à créer
        Set oSheetFrom = ThisWorkbook.Worksheets(2)
        For Each oCell In oSheetFrom.UsedRange.Columns(sColonne).Cells
            'On ignore la première ligne et les lignes n'ayant de code
            If oCell.Row > 1 And Not IsEmpty(oCell.Value) Then
                'On teste que l'élément de fait pas encore partie de la collection
                If Not Exists(aSheets, oCell.Value) Then
                    'On ajoute un élément contenant le code à la collection
                    aSheets.Add oCell.Value
                End If
            End If
        Next

        'On crée les feuilles splittées
        Set oSheetFrom = ThisWorkbook.Worksheets(2)
        'On boucle sur chaque élément de la collection
        For Each elSheet In aSheets
            'On ajoute une nouvelle feuille
            Set oSheetTO = ThisWorkbook.Worksheets.Add
            'On affecte le nom de la feuille en faisant précéder le code par un '_'
            oSheetTO.Name = "_" & elSheet
            'On recopie la ligne de titre de la feuille d'origine
            oSheetFrom.Rows(1).Copy
            oSheetTO.Range("A1").PasteSpecial xlAll
            'On parcourt toutes les ligne de la feuille d'origine
            For Each oRange In oSheetFrom.UsedRange.Rows
                'Si la colonne a une valeur identique à l'élément de la collection
                If oRange.Columns(sColonne).Value = elSheet Then
                    'On recopie la ligne de la feuille origine dans la feuille de destination
                    oRange.Copy
                    oSheetTO.Range("A" & CStr(oSheetTO.UsedRange.Rows.Count + 1)).PasteSpecial xlAll
                End If
            Next
            'On ajuste la taille des colonnes de la feuille de destination
            oSheetTO.UsedRange.Columns.AutoFit
        Next
    End If

    'On fait le ménage
    Set oSheetFrom = Nothing
    Set oSheetTO = Nothing
    Set oCell = Nothing
    Set oRange = Nothing
End Sub
Function Exists(coll As Collection, key As String) As Boolean
    Dim element As Variant
    'On passe en revue les éléments de la collection
    For Each element In coll
        'Si l'élément contient le code envoyé en paramètre on renvoitr la valeur vrai et on sort
        If key = element Then
            Exists = True
            Exit For
        End If
    Next
End Function

Et je joins mon fichier de tests :