Découpage d'un classeur Excel en plusieurs sous-classeurs

Le 18/11/2013 à 12:33

Bonjour,

Encore une fois, je vous sollicite votre aide : J'ai un fichier de format bien spécifique et qui comporte un code dans la colonne G

chaque semaine, je doit le découpe en plusieurs classeurs Excel suivant ce code (Colonne G) :je fait des filtres sur les codes un par un, ensuite je fait copier-coller dans des nouveaux classeurs nommées "Fichier_code xxxxx" (suivant le code en question)

Cette tâche est assez répétitive et ennuyante , donc est ce que quelqu'un peut m'orienter ?idéalement avec une Macro qui fait cette tâche en automatique

Veuillez trouver ci-joint un exemple de fichier Excel simplifié (j'ai effacé les données pour mesure de confidentialité)

PS:

  • Mon besoin est de respecter le format de fichier (nombre et libellé des colonnes)
  • Le code est toujours un nombre, par contre le format (texte ou nombre) peut être différent d'une ligne à l'autre (par exemple les nombres 2006 et 02006 représentent le même code, de même pour 24001 et 024001)
  • Les nouveaux classeurs à créer sont à enregistrer dans le même répertoire que le classeur d'origine avec le nom sous la forme suivante "Fichier_code xxxxx" ou xxxxx = code

D'avance, merci pour votre aide

A+

Le 18/11/2013 à 13:19

Bonjour,

une macro à tester

Dim nwb As Object, wss As Object, wsc As Object, i As Long, pl As Long, ocode As String
Sub decoupe()
' wss feuille source
    Set wss = ThisWorkbook.Sheets("feuil1")
'dlswss nombre de lignes dans wss
    dlwss = wss.Range("G" & Rows.Count).End(xlUp).Row
' on rend numérique tous les codes en colonne G    
For i = 2 To dlwss
        wss.Cells(i, "G") = wss.Cells(i, "G") + 0
    Next i
' on trie wss sur base de la colonne G
    With wss.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("G2:G" & dlwss), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:X" & dlwss)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'on commence la découpe
'ocode code en cours
    ocode = ""
'i numero de ligne en cours sur wss
    i = 2
' pl première ligne contenant le code ocode
    pl = i
' tant qu'il y a des lignes
    While i <= dlwss
' si le code en cours est différent du code trouvé sur la ligne en cours
        If ocode <> wss.Range("G" & i) Then
' et que le code n'est pas blanc
            If ocode <> "" Then
' on crée un nouveau classeur
                creeclasseur
            End If
' le nouveau code est celui de la ligne en cours
            ocode = wss.Range("G" & i)
' première ligne avec ce code est mis à jour
            pl = i
        Else
' on passe à la ligne suivante
            i = i + 1
        End If
    Wend
' on crée le dernier classeur
    creeclasseur
End Sub

Sub creeclasseur()
' nwb est le nouveau classeur
    Set nwb = Workbooks.Add
' nom du classeur contient le code
    wbfile = "Fichier_code_" & ocode & ".xlsx"
' on copiera dans la première feuille du nouveau classeur
    Set wsc = nwb.Worksheets(1)
' nom de la feuille contient aussi le code
    wsc.Name = "code_" & ocode
' on copie les entêtes de colonne
    wss.Range("A1:X1").Copy wsc.Range("A1")
' on copie toutes les lignes ayant le même code
    wss.Range("A" & pl & ":X" & i - 1).Copy wsc.Range("A2")
' on sauve le classeur
    nwb.SaveAs wbfile
' on ferme le classeur
    nwb.Close
End Sub
Le 18/11/2013 à 14:21

Bonjour,

Merci pour votre retour, cependant lors du test du votre code j'ai le message d'erreur "Erreur d’exécution '91' :variable objet ou variable de bloc With non définie " qui concerne le code suivant :

wss.Range("A1:X1").Copy wsc.Range("A1")

Pouvez vous le revoir ?

ps : le quel des 2 macros à éxécuter en 1 er lieu (creeclasseur ou decoupe)?

Merci d'avance

Le 18/11/2013 à 14:29

bonjour

sorry la macro est découpe et cela devrait fonctionner sans erreur. creeclasseur est une macro qui est utilisée dans découpe.

Le 18/11/2013 à 18:04

Bonjour,

Merci beaucoup pour votre retour, je viens d’exécuter la macro, par contre je ne trouve pas les nouveaux classeurs !

Normalement ils doivent être enregistrés dans le même dossier que le classeur initial ? Non ?

Merci d'avance pour cet éclaircissement

Bonne soirée

Pour info complémentaire : je viens de retrouver les classeurs crées par le découpage dans le dossier "Recovery" (dossier système office)!!

Le 18/11/2013 à 19:33

bonsoir,

code adapté pour créer les fichiers dans le même répertoire que le classeur source.

Dim nwb As Object, wss As Object, wsc As Object, i As Long, pl As Long, ocode As String, wsspath
Sub decoupe()
' wss feuille source
   Set wss = ThisWorkbook.Sheets("feuil1")
   wsspath = ThisWorkbook.Path
'dlswss nombre de lignes dans wss
   dlwss = wss.Range("G" & Rows.Count).End(xlUp).Row
' on rend numérique tous les codes en colonne G
For i = 2 To dlwss
        wss.Cells(i, "G") = wss.Cells(i, "G") + 0
    Next i
' on trie wss sur base de la colonne G
   With wss.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("G2:G" & dlwss), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:X" & dlwss)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'on commence la découpe
'ocode code en cours
   ocode = ""
'i numero de ligne en cours sur wss
   i = 2
' pl première ligne contenant le code ocode
   pl = i
' tant qu'il y a des lignes
   While i <= dlwss
' si le code en cours est différent du code trouvé sur la ligne en cours
       If ocode <> wss.Range("G" & i) Then
' et que le code n'est pas blanc
           If ocode <> "" Then
' on crée un nouveau classeur
               creeclasseur
            End If
' le nouveau code est celui de la ligne en cours
           ocode = wss.Range("G" & i)
' première ligne avec ce code est mis à jour
           pl = i
        Else
' on passe à la ligne suivante
           i = i + 1
        End If
    Wend
' on crée le dernier classeur
   creeclasseur
End Sub

Private Sub creeclasseur()
' nwb est le nouveau classeur
   Set nwb = Workbooks.Add
' nom du classeur contient le code
   wbfile = "Fichier_code_" & ocode & ".xlsx"
' on copiera dans la première feuille du nouveau classeur
   Set wsc = nwb.Worksheets(1)
' nom de la feuille contient aussi le code
   wsc.Name = "code_" & ocode
' on copie les entêtes de colonne
   wss.Range("A1:X1").Copy wsc.Range("A1")
' on copie toutes les lignes ayant le même code
   wss.Range("A" & pl & ":X" & i - 1).Copy wsc.Range("A2")
' on sauve le classeur
   nwb.SaveAs wsspath & "\" & wbfile
' on ferme le classeur
   nwb.Close
End Sub
Le 19/11/2013 à 15:10

Bonjour,

Très bien !!! un bon résultat

Merci beaucoup

A+

Rechercher des sujets similaires à "decoupage classeur classeurs"