Scinder un fichier en plusieurs onglets

Bon matin à tous,

Grâce au forum, j'ai trouvé une formule VBA qui fonctionne à merveille pour scinder mon fichiers en plusieurs onglets selon un critères bien précis.

J'aimerais pouvoir ajouter, à chaque onglets nouvellement créés, les trois premières lignes de l'onglets de départ : "Feuil1"

ainsi qu'un sous total (colonnes L à AB) à la dernière ligne de chaque onglet nouvellement créés.

Quelqu'un peut-il m'aider à placer la bonne commande au bon endroit,

Voici la formule que j'ai déniché sur le Forum(désolé je ne me souviens plus de qui elle était).

Sub creation_onglets()

Dim Ws As Worksheet

Dim trouve As Boolean

Dim contenu As String

Dim lig, derlig As Integer

With Sheets("Feuil1")

'à adapter Feuil1 = feuille ou sont vos données

derlig = .Range("A65536").End(xlUp).Row 'à adapter, E = colonne "Dossier groupe"

For lig = 2 To derlig

contenu = .Cells(lig, 1).Value

'à adapter 1 = 5ème col cf A ci dessus

For Each Ws In ThisWorkbook.Worksheets

trouve = False

If StrComp(Ws.Name, contenu, vbTextCompare) = 0 Then

trouve = True

Exit For

End If

Next Ws

If trouve = True Then

.Rows(lig).Copy Sheets(contenu).Range("A65536").End(xlUp).Offset(1, 0)

Else

Sheets.Add

ActiveSheet.Name = contenu

.Rows(lig).Copy Sheets(contenu).Range("A65536").End(xlUp).Offset(1, 0)

End If

Next lig

End With

End Sub

Bonsoir,

J'ai entièrement refait ton code, et rajouté les sommes voulues en fin de chaque onglet.

Tu cliques sur le dessin de la cellule E1 de l'onglet "base", et au bout de 2 secondes, tu as tous tes onglets de créés....

Tu noteras bien qu'il n'y a que 2 onglets, "base" et "modele", et ces 2 onglets sont impératifs

Le code :

Sub scinder()
Dim Cel As Range, Plg As Range
Dim DerLig As Long
Dim Numeros As Object
Dim Sh As Worksheet, FBase As Worksheet, FModele As Worksheet
Dim It As Variant
Set FBase = Sheets("base")
Set FModele = Sheets("modele")
Set Numeros = CreateObject("Scripting.Dictionary")
t = Timer
With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
End With
For Each Sh In Sheets
    If Sh.Name <> FBase.Name And Sh.Name <> FModele.Name Then
        Sh.Delete
    End If
Next Sh
With FBase
    DerLig = .Cells(Rows.Count, 1).End(xlUp).Row
    Set Plg = .Range("A3:AB" & DerLig)
    For Each Cel In .Range("A4:A" & DerLig)
        If Cel.Value <> "" Then
            Cel.Value = Format(Trim(Cel.Value), "0000")
            Numeros(Cel.Value) = Cel.Value
        End If
    Next Cel
End With
For Each It In Numeros.Items
    FModele.Copy After:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = It
        FBase.Range("BA4").FormulaR1C1 = "=RC1=" & It
        Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FBase.Range("BA3:BA4"), _
            CopyToRange:=.Range("A3:AB3"), Unique:=False
        DerLig = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        With .Cells(DerLig, "L")
            .FormulaR1C1 = "=SUM(R4C:R[-1]C)"
            .AutoFill Destination:=.Resize(1, 17)
        End With
    End With
Next It
FBase.Range("BA4").ClearContents
FBase.Select
MsgBox Timer - t
End Sub

Le fichier :

Bon courage

Wow!

Merci cousinhub

Je viens d'arriver au bureau, je vais tester aujourd'hui après les rencontres de la journée et les autres rapports à fournir. J'ai même le goût de "caller" malade pour tester le tout tranquille.

Comme je suis un néophyte VBA j'ai pas vraiment compris toute la formule mais un gros merci, je suis sûr que c'est parfait.

à plus tard.

Bon matin Cousinhub,

Effectivement, c'est parfait!! Merci.

Tu viens de nous sauver des heures de Copier-Coller.

Je vais même l'adapter pour un autre rapport du même genre.

Peut-être aurais-je des questions sur le pourquoi de certaines composantes de la formule.

Bon week-end

SPAGE

Bonjour à tous

BOnjour Cousinhub,

Je ne sais pas si tu te souviens, mais tu m'as "fabriqué" une macro pour scinder un fichier excel en plusieurs onglets. C'est vraiment d'une efficacité extra.

J'ai réussi à adapter cette dernière à de nouveaux rapports, sauf le dernier,

Je dois faire un onglet à chaque changement de valeurs de la colonne "C"

Les onglets se nomment de la bonne façon mais les données ne suivent pas.

Quelqu'un pourrait-il m'aider avec ce petit problème.

J'ai trouvé une solution boiteuse : je copie les données de la colonne "C" dans la colonne "A" et le tour est joué mais est-ce possible de ne pas "Copier-coller" et de faire suivre les données de la colonne C dans les onglets.

Cordialement

Spage

42mod-rem-split2.xlsm (56.14 Ko)

Bonsoir,

Dans le code, il faut que tu modifies la formule que je mets dans la cellule CA4...(qui me sert pour le filtre élaboré)

Pour le moment, tu as cette ligne :

......
......
        FBase.Range("CA4").FormulaR1C1 = "=RC1=" & It
......
......

Il faut que remplaces par ceci :

......
......
        FBase.Range("CA4").FormulaR1C1 = "=RC3=" & It
......
......

Bonne soirée

Bonsoir,

C'est encore exact et parfait!!

Ma question de débutant: Est-ce que le 3 de ''RC3'' correspond à la troisième colonne. Si oui, c'est-à-dire que si j'inscris ''RC4'', la macro filtrera sur la 4e colonne?????

Merci encore.

Cordialement

Spage

Bonjour à tous,

J'essai seulement de changer la formule SUM pour un sous total

Je pensais la formule OK mais elle est toujours en erreur.

Le haut de la formule est dans les messages précédents.

Merci.

de votre aide

For Each It In Numeros.Items

FModele.Copy After:=Sheets(Sheets.Count)

With ActiveSheet

.Name = It

FBase.Range("CA4").FormulaR1C1 = "=RC3=" & It

Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=FBase.Range("CA3:CA4"), _

CopyToRange:=.Range("A3:BM3"), Unique:=False

DerLig = .Cells(Rows.Count, 1).End(xlUp).Row + 2

With .Cells(DerLig, "O")

.FormulaR1C1 = "=SUBTOTAL(9;R[4]C:R[-1]C)"

.AutoFill Destination:=.Resize(1, 46)

End With

End With

Next It

FBase.Range("CA4").ClearContents

FBase.Select

MsgBox Timer - t

End Sub

J'ai trouvé grâce à NAD

Il faut mettre une (9,RC:RC) au lieu de (9;RC:RC)

BOnne journée

Rechercher des sujets similaires à "scinder fichier onglets"