Macro de découpage de fichier excel - Changement de nom et de destination

[GADENSEB]

Bonjour,
J'ai récupéré une macro qui une fois copier dans un fichier permet de découper ce fichier selon une colonne choisie

en plusieurs fichiers excel :

Dans le fichier joinr si je choisi le "service" - colonne C il va faire 3 fichiers puisqu'il y a 3 services différents.
etc... sur les autres colonnes


Cette marco est super mais je voudrais l'intégrée en XLA pour l'utilisée sur n'importe quel fichier

2 problèmes se posent :

1 - Le dossier d'enregistrement :

Ici le dossier est par défaut le dossier de la marco -> donc le futur dossier XLA
Je voudrais transformer le code pour que je puisse choisir le dossier de destination

2 - Le nom du fichier :

Ici par défaut le nom commun à tous les fichiers est "Service" là aussi à l'enregistrement je voudrais choisir le nom commun de tous les fichiers générés


Qui à une idée ?

bonne journée

Seb

Option Explicit

'
' compileARTT Macro
' Macro enregistrée le 09/10/2014 Par Sébastien GADEN
'
Sub Decoupage()

Dim Service As New Collection
Dim Plage As Range
Dim col3 As Integer
Dim L As Long, L2 As Long, Lmax As Long
    'évite le scintillement de l'écran
    Application.ScreenUpdating = False
 With ActiveSheet
 'With Sheets("Feuil1")       'A adapter en fonction de la feuille où sont les données!
        Lmax = .Cells(Application.Rows.Count, 1).End(xlUp).Row
        'Création de la liste des services (sans doublons)
        col3 = InputBox(Prompt:="Quel est le n° de colonne pour le tri?")
        On Error Resume Next
        For L = 2 To Lmax
            Service.Add .Cells(L, col3).Text, .Cells(L, col3).Text
        Next L
        On Error GoTo 0
        'Création des classeurs
        For L = 1 To Service.Count
            'Copie de l'onglet
            .Copy
            'Epurage des données par service
            With ActiveSheet
                Set Plage = .Rows(Application.Rows.Count)
                For L2 = 2 To Lmax
                    If .Cells(L2, col3).Text <> Service(L) Then
                        Set Plage = Union(Plage, .Rows(L2))
                    End If
                Next L2
                Plage.Delete
            End With
            'Sauvegarde classeur "Catégorie X"
            With ActiveWorkbook
                .SaveAs ThisWorkbook.Path & "\Service " & Service(L) & ".xlsx"
                'ActiveWorkbook.SendMail Recipients:=Range("A2").Value
               .Close
            End With
        Next L
    End With
    Application.ScreenUpdating = True
    MsgBox Service.Count & " classeurs créés"
End Sub

 

[john]

Re : Macro de découpage de fichier excel - Changement de nom et de destination

Bonjour,

Voici une solution dans le fichier joint (ton fichier modifié).

Bonne journée.

John

 

[Robert]

Re : Macro de découpage de fichier excel - Changement de nom et de destination

Bonjour Gadenseb, john, bonjour le forum,

Trop rapide John !
Une autre proposition très similaire mais qui déclenche la macro au Double-Clic dans une cellule éditée. La colonne COL est déterminée par la colonne de la cellule double-cliquée...

Le fichier :

 

[GADENSEB]

Re : Macro de découpage de fichier excel - Changement de nom et de destination

Hello
Trop fort tous les deux !

Je garde les 2 versions !!!


Merci


Bonne aprem

Seb

 

[john]

Re : Macro de découpage de fichier excel - Changement de nom et de destination

Re,

hihihi

Bonne journée à vous.

John

 

[GADENSEB]

Re : Macro de découpage de fichier excel - Changement de nom et de destination

Bonjour à tous les deux et au Forum

@ John
ta version me semble la plus adaptée pour mon besoin


Par contre, dans ta version :
- Je peux choisir le nom du fichier et la destination -> Nikel
- Mais la macro incrémente un numéro de fichier alors que dans la version première du code, les fichiers étés nommés avec le contenu de la sélection --> yaurais moyen de revenir à cela ?


en deuxiéme temps je voudrais intégrer une barre de progression .....

Mais là je rame .... j'ai récupéré un code mais je sais pas trop ou le placé ....


Qqn aurait une idée?

Bonne journée

seb

Sub Main()
'   Inserts random numbers on the active worksheet
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single
    
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    Cells.Clear
    Counter = 1
    RowMax = 200
    ColMax = 25
    For r = 1 To RowMax
        For c = 1 To ColMax
            Cells(r, c) = Int(Rnd * 1000)
            Counter = Counter + 1
        Next c
        PctDone = Counter / (RowMax * ColMax)
        Call UpdateProgress(PctDone)
    Next r
    Unload UserForm1
End Sub


Sub UpdateProgress(Pct)
    With UserForm1
        .FrameProgress.Caption = Format(Pct, "0%")
        .LabelProgress.Width = Pct * (.FrameProgress.Width - 10)
        .Repaint
    End With
End Sub

 

[john]

Re : Macro de découpage de fichier excel - Changement de nom et de destination

Bonjour,

Voilà le fichier avec les modifications demandées

Bonne journée.

John

 

[GADENSEB]

Re : Macro de découpage de fichier excel - Changement de nom et de destination

au poil !!!

Merci

Bonne journée

 

[john]

Re : Macro de découpage de fichier excel - Changement de nom et de destination

au poil !!!

Merci

Bonne journée

de rien
Bonne journée également.