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
 

Pièces jointes

  • Compta Analytique.xlsx
    16.8 KB · Affichages: 41

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 Accro
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
 

Pièces jointes

  • Compta Analytique VBA.xlsm
    35.5 KB · Affichages: 21

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.
 

Pièces jointes

  • michel-nac Compta Analytique v1a.xlsm
    29.1 KB · Affichages: 31
Dernière édition:

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
 

Pièces jointes

  • michel-nac Compta Analytique Chti160.xlsm
    37.9 KB · Affichages: 25

Discussions similaires

Réponses
22
Affichages
690
Réponses
6
Affichages
99

Statistiques des forums

Discussions
311 721
Messages
2 081 927
Membres
101 842
dernier inscrit
seb0390