Ventilation sur plusieurs feuilles par code

michel-nac

XLDnaute Nouveau
Bonjour à tous,

je reviens vers vous pour un autre sujet si vous le permettez.
dans mon fichier j'ai au début Feuil 1 ou j'ai un tableau exporté d'un logiciel de comptabilité.
ce que je cherche: un coder à lier au bouton ventilation que j'ai das la colonne Y (Feuil1) qui permet de ventiler le même tableau mais par code que j'ai dans la colonne B.

j'ai fait un exemple manuellement:
pour le code B2: le code copie l'entête du tableau CAD la première ligne ensuite le ligne du code B2 qui se trouve sur une seule ligne sans oublier nommer la feuille avec le code

pour le code B3: le code copie l'entête du tableau CAD la première ligne ensuite les lignes 3, 4, 5, 6, 7, 8 parce que dans la colonne B ont le même code sans oublier nommer la feuille avec le code

le code doit faire pareil pour tout le tableau

merci d'avance pour votre assistance

Amicalement
Michel
 

Fichiers joints

Chris401

XLDnaute Accro
Bonsoir
Essaye ce code
Code:
Sub CreerOnglets()
Application.ScreenUpdating = False

Dim Feuille As Worksheet
    For Each Feuille In ThisWorkbook.Worksheets
        If Feuille.Name <> "Feuil1" Then
        Application.DisplayAlerts = False
            Feuille.Delete
        Application.DisplayAlerts = True
        End If
    Next Feuille

Range("A1:W" & [A65000].End(xlUp).Row).Name = "Base"
Range("A1:W1").Name = "Titres"

Set Nouveau = CreateObject("Scripting.Dictionary")

    For Each cel In Range("B2:B" & [B65000].End(xlUp).Row)
        If Not Nouveau.Exists(cel.Value) Then Nouveau.Add cel.Value, cel.Value
    Next cel
    For Each It In Nouveau.items
        NouvelleFeuille = Nouveau.Item(It)
        On Error Resume Next
        Set connue = Sheets(NouvelleFeuille)
            If Err <> 0 Then Sheets.Add.Name = NouvelleFeuille
        On Error GoTo 0
        With ActiveSheet
            .Range("A1:W1").Value = Range("Titres").Value
            .[Y1] = "Compte général"
            .[Y2] = NouvelleFeuille
            Range("Base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range( _
                "Y1:Y2"), CopyToRange:=.Range("A1:W1"), Unique:=False
            .[Y1:Y2].ClearContents
        End With
    Next It
    Sheets("Feuil1").Move Sheets(1)
    Sheets("Feuil1").Select
End Sub
 

michel-nac

XLDnaute Nouveau
Bonsoir Chris,

je vous remercie pour la promptitude de votre réponse.
après un test sur le fichier je confirme que c'est bien ce que je voulais comme résultat, reste juste deux petites rectifications à rajouter si possible.

1-les feuilles créées seront classées par ordre croissant, c'est a dire par feuille qui a comme nom le code le plus petit jusqu'à celle qui comme nom la la valeur la plus élevée.

2- les tableaux des feuilles créées doivent être cadrés par bordure de type xlContinuous et au milieu du tableau bordures de type xlDot, et la première ligne des tableaux soit coloré en vert.

merci encore une autre fois pour votre assistance

Amicalement
 

Chris401

XLDnaute Accro
Re
Je ne comprends pas la partie : "et au milieu du tableau bordures de type xlDot"
Pour le reste
Code:
Sub CreerOnglets()
Application.ScreenUpdating = False

Dim Feuille As Worksheet
    For Each Feuille In ThisWorkbook.Worksheets
        If Feuille.Name <> "Feuil1" Then
        Application.DisplayAlerts = False
            Feuille.Delete
        Application.DisplayAlerts = True
        End If
    Next Feuille

Range("A1:W" & [A65000].End(xlUp).Row).Name = "Base"
Range("A1:W1").Name = "Titres"

Set Nouveau = CreateObject("Scripting.Dictionary")

    For Each cel In Range("B2:B" & [B65000].End(xlUp).Row)
        If Not Nouveau.Exists(cel.Value) Then Nouveau.Add cel.Value, cel.Value
    Next cel
    For Each It In Nouveau.items
        NouvelleFeuille = Nouveau.Item(It)
        On Error Resume Next
        Set connue = Sheets(NouvelleFeuille)
            If Err <> 0 Then Sheets.Add.Name = NouvelleFeuille
        On Error GoTo 0
        With ActiveSheet
            .Range("A1:W1").Value = Range("Titres").Value
            .Range("A1:W1").Interior.Color = RGB(0, 176, 80)
            .[Y1] = "Compte général"
            .[Y2] = NouvelleFeuille
            Range("Base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range( _
                "Y1:Y2"), CopyToRange:=.Range("A1:W1"), Unique:=False
            .[Y1:Y2].ClearContents
            Range("A1").CurrentRegion.Borders.Value = 1
         End With
    Next It
    Sheets("Feuil1").Move Sheets(1)
  
    Dim a(256)
    n = Sheets.Count
    For i = 2 To n
        a(i) = Sheets(i).Name
    Next i
    For i = 1 To n
        For j = i To n
            If a(j) < a(i) Then
                temp = a(j)
                a(j) = a(i)
                a(i) = temp
            End If
        Next j
    Next i
    For i = 2 To n
        Sheets(a(i)).Move before:=Sheets(i)
    Next i
    Sheets("Feuil1").Select
End Sub
 

michel-nac

XLDnaute Nouveau
Re-Bonsoir Chris,

ce que je voulais dire c'est la largeur des colonnes des feuilles créées doit être la même que celle des colonnes de l'onglet Feuil1.
par exemple pour la colonne A de la feuille Feuil1 la largeur est 13,43 donc les colonnes A de toutes les feuilles qui seront créées doivent être aussi 13,43 pour but que l'écriture soit visible.

je vous remercie infiniment pour la rapidité de vos réponses.

Amicalement
 

laurent950

XLDnaute Impliqué
Bonjour,
J'ai fait un code plus simple et très adaptable
je joint le modèle

VB:
' Module1 standard code a copier

Sub Repart()
Dim F1 As Worksheet
Set F1 = Worksheets("Feuil1")

Dim TabRepart() As Variant
    TabRepart = F1.Range(F1.Cells(1, 1), F1.Cells(F1.Cells(65536, 1).End(xlUp).Row, 23))
        ReDim Preserve TabRepart(LBound(TabRepart, 1) To UBound(TabRepart, 1), LBound(TabRepart, 2) To 25)

Dim MonObjet As Methode
Set MonObjet = New Methode

' Reperage des doublons
    MonObjet.doublon = TabRepart
' Compteur = Nombres de feuilles par code
    MonObjet.Cpt
' Creation de tableau pour stocké les valeurs
    MonObjet.CreationFeuil
' coller les valeurs dans les feuilles correspondantes
    MonObjet.TransfertVal
End Sub

' ici le module de classe avec nom Methode

Private mTabRepart() As Variant
Private mCpt As Integer
Property Let doublon(TabRepart() As Variant)
mTabRepart = TabRepart
' reperage des doublons
For i = LBound(mTabRepart, 1) To UBound(mTabRepart, 1)
    mTabRepart(i, 24) = mTabRepart(i, 2)
    For j = i + 1 To UBound(mTabRepart, 1)
        If mTabRepart(i, 2) = mTabRepart(j, 2) Then
            mTabRepart(i, 24) = ""
        End If
    Next j
Next i
End Property
Sub Cpt()
    For i = LBound(mTabRepart, 1) To UBound(mTabRepart, 1)
        If mTabRepart(i, 24) <> Empty Then
            mCpt = mCpt + 1
        End If
    Next i
End Sub
Sub CreationFeuil()
For i = 2 To UBound(mTabRepart, 1)
    If mTabRepart(i, 24) <> Empty Then
        Set Ftemp = Sheets.Add(After:=Sheets(Sheets.Count))
            Ftemp.Name = CStr(mTabRepart(i, 24))
                    For j = LBound(mTabRepart, 2) To UBound(mTabRepart, 2) - 2
                         Sheets(CStr(mTabRepart(i, 2))).Cells(1, j) = mTabRepart(1, j)
                    Next j
    End If
Next i
End Sub
Sub TransfertVal()
Dim F As Worksheet
For i = 2 To UBound(mTabRepart, 1)
    For j = LBound(mTabRepart, 2) To UBound(mTabRepart, 2) - 2
        Set NonFeuil = Sheets(CStr(mTabRepart(i, 2)))
            NonFeuil.Cells(NonFeuil.Cells(65536, j).End(xlUp).Row + 1, j) = mTabRepart(i, j)
        Set NonFeuil = Nothing
    Next j
Next i
End Sub
 

Fichiers joints

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir à tous,

Un autre essai qui utilise un TCD et qui fonctionne sur Excel 2010.

Les feuilles ventilées sont nommées avec le numéro du Compte général précédé d'un tiret. Ce tiret est utile car il permet de distinguer les feuilles ventilées des autres feuilles. En effet, à chaque exécution de la macro, il faut pouvoir supprimer les feuilles ventilées d'une précédente ventilation. Et ces feuilles seront repérées par le tiret précédent leur nom. Les feuilles ventilées sont classées par ordre croissant de leur nom. Les colonnes des feuilles ventilées possèdent les largeurs des colonnes de la feuille source.
 

Fichiers joints

Dernière édition:

Chris401

XLDnaute Accro
Ajoute la ligne en rouge

.......
Range("A1").CurrentRegion.Borders.Value = 1
Columns.EntireColumn.AutoFit
End With
.........
 

ChTi160

XLDnaute Barbatruc
Bonjour michel-nac
Bonjour le Fil , le Forum
ça me rappelle le fichier Balence.xlsx de an@s(serait ce un travail d'équipe? lol)
Bonne journée
jean marie
 

ChTi160

XLDnaute Barbatruc
Re
Une autre approche perfectible
En copiant la feuille Source ("Feuil1") en la renomment et ensuite éliminer les données non concernées .
pas traité la suppression des feuilles , pour nouveau transfert .
a améliorer la remise en forme des tableaux (quadrillage etc) qui sont modifiés dans chaque feuille.
jean marie
 

Fichiers joints

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas