Fragmenter un tableau et créer des feuilles et coller

Bonjour

j'ai un macro qui est les suivant :

Sub fragmenter()
Dim i%, cle As Variant, sw As Worksheet, dico As Object, tbl As Variant

Set sw = ActiveSheet
Set dico = CreateObject("Scripting.Dictionary")

With ActiveSheet.ListObjects(1)

If .ShowAutoFilter Then .AutoFilter.ShowAllData

tbl = .ListColumns(6).DataBodyRange ' critere en colonne 6 (F)
For i = 2 To UBound(tbl)
dico(tbl(i, 1)) = dico(tbl(i, 1)) + 1
Next

For Each cle In dico.Keys
.Range.AutoFilter Field:=6, Criteria1:=cle
.Range.Select
Selection.Copy
Sheets.Add After:=ActiveSheet
Range("A14").Select
With ActiveSheet
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.ListObjects.Add(xlSrcRange, Range("A14").CurrentRegion, , xlYes).Name = cle
.ListObjects(1).TableStyle = "TableStyleMedium2"
.Name = cle
End With
sw.Select

Next

.AutoFilter.ShowAllData

End With

End Sub

je veux que ce macro soit modifié pour :

1- copier et coller l’entête A1 : F11 sur chaque feuille créée avec le tableau sélectionné à partir du filtre

2- mettre la lettre du filtre dans la cellule D2 dans chaque feuille créée

( voir pièce jointe )

1000 merci

Bonjour,

Veuillez à utiliser les balises de code </> lorsque vous postez un code sur le forum.

Sinon, voici votre fichier en retour pour test.

Le bouton Fragmenter est supprimé. Vous pouvez exécuter le code en cliquant sur le logo en haut à gauche. Une instruction dans le code supprimer le lien du code avec le bouton pour chaque feuille Copiée

Cordialement

MERCI DAN :)

bonjour DAN

si ce n'est pas trop demandé...

pouvez vous ajouter un macro pour qu'il crée des dossiers avec les noms des section et copie coller seulement la feuille concerné dans le classeur!!!???

merci infiniment :)

Bonjour

qu'il crée des dossiers avec les noms des section et copie coller seulement la feuille concerné dans le classeur!!!???

1. Heu créer des dossiers ? Où ?

2. Vous devez quand même garder les feuilles créées dans le fichier ou pas ?

Re-bonjour Dan

créé un dossier sur le bureau par exemple ( je peut changer l'emplacement après)

oui il faut garder les feuilles dans le fichier

merci

re

créé un dossier sur le bureau par exemple ( je peut changer l'emplacement après)

Ok mais il me faut le lien pour le répertoire. c:\........ ou alors le plus simple est de mettre les fichiers au même endroit que le fichier lead

oui je confirme

les mètres au même endroit que le fichier lead

Re

Ok. Alors faite ceci :

- Si votre fichier LEAD est sur votre Bureau, creez un dossier et ensuite mettez-y le fichier LEAD
- Dans la macro "Fragmenter", mettez ceci juste au dessus de l'instruction NEXT ITEM --> Call CopierOngletDansNouveauClasseur
- Ajoutez ensuite le code dans le module

Sub CopierOngletDansNouveauClasseur()
Dim NouveauClasseur As Workbook
Dim Chemin As String, Fichier As String

Chemin = ThisWorkbook.Path & "\"

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

 'copie de l'onglet à exporter
ThisWorkbook.ActiveSheet.Copy
Fichier = ActiveSheet.Name
Set NouveauClasseur = ActiveWorkbook

With NouveauClasseur 'avec ce nouveau classeur
    .SaveAs Filename:=Chemin & Fichier & ".xlsx" 'enregistrer le fichier sous le chemin
    .Close 'Fermeture du nouveau fichier
End With

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

Cordialement

Sub Fragmenter()

Dim Section As New Collection
Dim item
Dim cel As Range
Dim i As Integer

With Sheets("LEAD")
    On Error Resume Next
        For Each cel In .Range("F11:F" & .Range("F" & .Rows.Count).End(xlUp).Row)
            Section.Add cel.Value, CStr(cel.Value)
        Next cel
    On Error GoTo 0
End With

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

    For Each item In Section
        Sheets("LEAD").Copy After:=Sheets(Worksheets.Count)
        With ActiveSheet
            .Name = item
            .Range("D2") = item
            For i = .Range("F" & .Rows.Count).End(xlUp).Row To 11 Step -1
                If .Range("F" & i) <> item Then .Range("F" & i).EntireRow.Delete
            Next i
            .Shapes(1).OnAction = ""
        End With
    Next item
    Sub CopierOngletDansNouveauClasseur()
Dim NouveauClasseur As Workbook
Dim Chemin As String, Fichier As String

Chemin = ThisWorkbook.Path & "\"

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

 'copie de l'onglet à exporter
ThisWorkbook.ActiveSheet.Copy
Fichier = ActiveSheet.Name
Set NouveauClasseur = ActiveWorkbook

With NouveauClasseur 'avec ce nouveau classeur
    .SaveAs Filename:=Chemin & Fichier & ".xlsx" 'enregistrer le fichier sous le chemin
    .Close 'Fermeture du nouveau fichier
End With

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

ne marche pas et même quand je le mets dans une nouvelle bouton il ne copie qu'une seule feuille

Heu oui désolé j'avais pas écrit

Dans la macro Fragmenter, ce n'est --> Sub CopierOngletDansNouveauClasseur() mais CALL CopierOngletDansNouveauClasseur

Attention ne pas mettre les paranthèses

Cordialement

erreur e compilation

sub ou fonction non définie

   End With
    Next item
  Call CopierOngletDansNouveauClasseur
Dim NouveauClasseur As Workbook
Dim Chemin As String, Fichier As String

Chemin = ThisWorkbook.Path & "\"

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Normal, il y a deux macros et non pas une

Comme ceci

Sub Fragmenter()

Sub Fragmenter()

Dim Section As New Collection
Dim item
Dim cel As Range
Dim i As Integer

With Sheets("LEAD")
    On Error Resume Next
        For Each cel In .Range("F11:F" & .Range("F" & .Rows.Count).End(xlUp).Row)
            Section.Add cel.Value, CStr(cel.Value)
        Next cel
    On Error GoTo 0
End With

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

    For Each item In Section
        Sheets("LEAD").Copy After:=Sheets(Worksheets.Count)
        With ActiveSheet
            .Name = item
            .Range("D2") = item
            For i = .Range("F" & .Rows.Count).End(xlUp).Row To 11 Step -1
                If .Range("F" & i) <> item Then .Range("F" & i).EntireRow.Delete
            Next i
            .Shapes(1).OnAction = ""
        End With
        Call CopierOngletDansNouveauClasseur
    Next item
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Sub CopierOngletDansNouveauClasseur()
Dim NouveauClasseur As Workbook
Dim Chemin As String, Fichier As String

Chemin = ThisWorkbook.Path & "\"

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

 'copie de l'onglet à exporter
ThisWorkbook.ActiveSheet.Copy
Fichier = ActiveSheet.Name
Set NouveauClasseur = ActiveWorkbook 'classeur de destination

With NouveauClasseur 'avec ce nouveau classeur
    .SaveAs Filename:=Chemin & Fichier & ".xlsx" 'enregistrer le fichier sous le chemin
    .Close 'Fermeture du nouveau classeur
End With

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

oui ca marche

merci