XL 2021 Macro de découpage suivant une clé

[Popov63]

Bonjour à toute la communauté !

Je débute en macro et VBA.
Je cherche à découper un fichier en plusieurs fichier Excel suivant une clé contenue dans la colonne "CLE". (exemple, si deux lignes contiennent la clé "A" et une ligne la clé "B", je souhaite que ma macro découpe mon fichier initial en deux fichiers: l'un avec les deux lignes de la clé "A" et l'autre avec une seule ligne de la clé "B")

J'ai deux soucis dans mon fichier ci-joint:
1-J'arrive à découper uniquement le premier onglet de mon fichier "SynthesisWorkforceList", j'aimerai que pour chaque fichier excel découpé, il y ait également l'onglet "Appendice" joint.
2- La découpe se fait en valeur alors que j'aimerais garder les formules

Merci d'avance pour votre aide précieuse !

Pierre

 

[sousou]

Bonjour
REgarde comme ceci

 

[Popov63]

Bonjour Sousou,

merci pour ton retour !
Il semblerait que ça ne fonctionne pas 🙁 voici la ligne mise en jaune par le débogueur :

 

[dysorthographie]

bonjour,
je t'invites à supprimer les données de ton tableau structuré et de l'enregistrer sous modèle avec prise en compte des macros.

ainsi tu pourras créer un nouveau classeur sur la base de ce modèle et ainsi tu récupèreras les formules.

je t'invite à positionner le modèle dans le même répertoire que l'application.

dim newClasseur as workbook
set newClasseur= workbooks.add(thisworkbook.path & "\modele.xltm")

 

[Popov63]

bonjour,
je t'invites à supprimer les données de ton tableau structuré et de l'enregistrer sous modèle avec prise en compte des macros.

ainsi tu pourras créer un nouveau classeur sur la base de ce modèle et ainsi tu récupèreras les formules.

je t'invite à positionner le modèle dans le même répertoire que l'application.

dim newClasseur as workbook
set newClasseur= workbooks.add(thisworkbook.path & "\modele.xltm")

Bonjour,
merci pour ta réponse, j'avoue que je ne comprends pas grand chose 🙁
Mon fichier est bien enregistré sous modèle avec prise en compte des macros.
Que signifie "positionner le modèle dans le même répertoire que l'application" ?

Merci !

 

[dysorthographie]

Excel enregistre toujours ces modèles dans un répertoire a lui.

pour l'ouvrir il faut préciser le dossier dans lequel ce trouve le modèle.

si tu choisis de placer le modèle au même emplacement que ton application il te suffit d'écrire thisworkbook.path pour en connaître l'emplacement ainsi si tu fourni ton application a un ami tu n'as pas a modifier le code Car a chaque son Excel et son emplacement de modèle

 

[sousou]

Bonjour Sousou,

merci pour ton retour !
Il semblerait que ça ne fonctionne pas 🙁 voici la ligne mise en jaune par le débogueur :

Regarde la pièce jointe 1225987

pas ce problème chez moi

 

[dysorthographie]

Function arrUnique() As Variant
arrUnique = WorksheetFunction.Unique(Worksheets("SynthesisWorkforceList").ListObjects("Workforce_List").ListColumns("CLE").DataBodyRange)
End Function
Function Filtre(value As String) As Variant
    Filtre = Evaluate("=FiltreRd(Workforce_List, Workforce_List[CLE], """ & value & """)")
End Function

Sub CynderFichier()
Dim arrResult As Variant


Dim CLE
For Each CLE In arrUnique
    Debug.Print CLE
    GestionFichier CStr(CLE)
  Next
End Sub

Function GestionFichier(CLE As String) As Boolean
Dim Resultat: Resultat = Filtre(CStr(CLE))
Dim L As Integer, C As Integer
On Error Resume Next
L = UBound(Resultat, 1)
C = UBound(Resultat, 2)
If Err Then
    L = 1: C = UBound(Resultat, 1)
    Resultat = Application.transpouse(Resultat)
End If
If Dir(ThisWorkbook.Path & "\Cible", vbDirectory) = "" Then MkDir ThisWorkbook.Path & "\Cible"
If Dir(ThisWorkbook.Path & "\Cible\" & CLE & ".xlsm") <> "" Then Kill ThisWorkbook.Path & "\Cible\" & CLE & ".xlsm"
With Workbooks.Add(ThisWorkbook.Path & "\Modèle\Data Set Macro Decoupe.xltm")

    With Worksheets("SynthesisWorkforceList").ListObjects("Workforce_List")
    If .DataBodyRange Is Nothing Then .ListRows.Add
        .Resize .Range.Resize(1 + L, C)
        .DataBodyRange.value = Resultat
    End With

    .SaveAs Filename:=ThisWorkbook.Path & "\Cible\" & CLE & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
   
    .Close False
End With

End Function

=LAMBDA(tbl;col;critere;
    FILTRE(tbl;ESTNUM(CHERCHE(critere;col)))
)

 

[Cousinhub]

pas ce problème chez moi

Bonsoir,
Peut-être qu'il a cette config?

Et ton code sous-entend au moins 2 onglets

Bonne soirée

Edit, voir peut-être du côté de :

Application.SheetsInNewWorkbook

A utiliser avec toutes les précautions d'usage, bien sûr...
Si la valeur par option de l'utilisateur est à 1, mémoriser cette valeur, la modifier, créer le nouveau classeur, puis remettre comme avant...

 

[job75]

Bonsoir Popov63, le forum,

Créer un fichier modèle me paraît inutile, voyez le fichier joint et cette macro :

Sub Decoupage()
Dim colref%, chemin$, d As Object, i&, x$, a, b
colref = 2 'colonne du tableau source contenant les clés
chemin = ThisWorkbook.Path & "\Fichiers clés\" 'sous-dossier
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier s'il n'existe pas
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si les fichiers clés ont déjà été créés
With Sheets("SynthesisWorkforceList").ListObjects(1).Range 'tableau structuré
    For i = 2 To .Rows.Count
        x = UCase(.Cells(i, colref)) 'clé en colonne B
        d(x) = d(x) + 1 'comptage des valeurs uniques
    Next i
    a = d.keys: b = d.items
    .Parent.Copy 'feuille copiée dans un 1er document auxiliaire
End With
With ActiveSheet.ListObjects(1).Range 'tableau structuré
    .AutoFilter: .AutoFilter 'désactive le filtrage s'il existe
    .Columns(.Columns.Count + 1).Resize(, Columns.Count - .Columns.Count - .Column + 1).Delete xlToLeft 'vide à droite
    .Parent.DrawingObjects.Delete 'supprime le bouton
    .Columns(colref).Insert xlToRight 'insère une colonne auxiliaire
    For i = 0 To UBound(a)
        .Columns(colref).FormulaR1C1 = "=1/(RC[1]=""" & a(i) & """)"
        .Columns(colref) = .Columns(colref).Value 'supprime les formules
        .Sort .Columns(colref), xlAscending, Header:=xlYes 'le tri place la clé au début du tableau pour accélérer
        .Parent.Copy '2ème document auxiliaire
        With ActiveSheet.ListObjects(1).Range 'tableau structuré
            .Columns(colref).Delete xlToLeft 'supprime la colonne auxiliaire
            If .Rows.Count > b(i) + 1 Then .Rows(b(i) + 2).Resize(.Rows.Count - b(i) - 1).Delete xlUp 'supprime les lignes en dessous
        End With
        ThisWorkbook.Sheets("Appendice").Copy After:=ActiveSheet 'ajoute la feuille Appendice
        Sheets(1).Activate
        If Trim(a(i)) = "" Then a(i) = "(vide)"
        ActiveWorkbook.SaveAs chemin & a(i) & ".xlsx", 51 'enregistre le fichier
        ActiveWorkbook.Close 'ferme le fichier créé
    Next i
    .Parent.Parent.Close False 'ferme le 1er document auxiliaire
End With
MsgBox UBound(a) + 1 & " fichier" & IIf(UBound(a), "s .xlsx ont été créés...", " .xlsx a été créé...")
End Sub

La macro crée le sous-dossier "Fichiers clés" pour recevoir les fichiers créés.

Notez que pour les formules en colonne U de la 1ère feuille j'ai dû créer 3 noms définis se référant à la feuille "Appendice".

Bonne nuit.

Edit 1 : j'ai modifié la macro pour qu'elle ne modifie pas la feuille source.

Edit 2 : le petit tableau Z2:AC3 n'est pas copié, si vous voulez le conserver neutralisez la ligne :

.Columns(.Columns.Count + 1).Resize(, Columns.Count - .Columns.Count - .Column + 1).Delete xlToLeft 'vide à droite

 

[job75]

Bonjour le forum,

Pour éviter les caractères interdits dans les noms des fichiers on peut mettre en colonne B de la 1ère feuille cette formule de validation :

=ET(ESTERR(TROUVE(CAR(160);B2));ESTERR(TROUVE("\";B2));ESTERR(TROUVE("/";B2));ESTERR(TROUVE(":";B2));ESTERR(TROUVE("*";B2));ESTERR(TROUVE("?";B2));ESTERR(TROUVE("""";B2));ESTERR(TROUVE("<";B2));ESTERR(TROUVE(">";B2));ESTERR(TROUVE("|";B2)))

J'y ai ajouté l'espace insécable de code 160.

 

[mapomme]

Bonjour à tous😉,

J'avais un peu de temps. J'ai donc pondu une macro de ventilation. Pour varier un peu, je n'ai pas utilisé de "dictionary" pour l'unicité des clefs.
Comme @job75 a commenté son code, je l'ai aussi fait. Comme @job75 a évoqué les caractères interdits des noms de fichiers, j'en ai tenu compte en remplaçant ces caractères par le caractère "souligné".

Pour lancer la macro, il faut double-cliquer sur la cellule B1. (code de lancement dans le module de la feuille). Sinon le code principal est dans Module1.

 

[job75]

Bonjour le forum,

Pour les caractères interdits voici une formule de validation plus simple en B2 :

=NB(TROUVE(STXT(CAR(160)&"\/:*?""<>|";LIGNE(INDIRECT("1:10"));1);B2))=0

@mapomme dans le fichier d'origine il y a des formules en colonnes U V X de la 1ère feuille, ta solution ne les conserve pas :

2- La découpe se fait en valeur alors que j'aimerais garder les formules

A+

 

[mapomme]

Bonjour @job75😉,

@mapomme dans le fichier d'origine il y a des formules en colonnes U V X de la 1ère feuille, ta solution ne les conserve pas :

Je n'avais pas fait attention. On va corriger mais pas cette après-midi...

 

[job75]

Bonjour le forum,

Pour tester la macro du post #10 j'ai copié le tableau A2:X5 sur 10 000 lignes, elle s'exécute chez moi en 9,8 secondesi.

Cette macro avec des tableaux VBA s'exécute en 4,3 secondes :

Sub Decoupage()
Dim colref%, chemin$, LO As ListObject, tablo, nlig&, ncol%, d As Object, i&, a, resu(), k%, cle$, n&, j&
colref = 2 'colonne du tableau source contenant les clés
chemin = ThisWorkbook.Path & "\Fichiers clés\" 'sous-dossier
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'crée le sous-dossier s'il n'existe pas
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si les fichiers clés ont déjà été créés
Sheets("SynthesisWorkforceList").Copy '1er document auxiliaire
Set LO = ActiveSheet.ListObjects(1) 'tableau structuré
tablo = LO.Range.Formula 'tableau des formules
nlig = UBound(tablo)
ncol = UBound(tablo, 2)
LO.AutoFilter.ShowAllData 'désactive le filtre s'il existe
If Not LO.DataBodyRange Is Nothing Then LO.DataBodyRange.Delete xlUp 'RAZ
With LO.Range
    .Columns(.Columns.Count + 1).Resize(, Columns.Count - .Columns.Count - .Column + 1).EntireColumn.Delete 'facultatif, vide à droite
    .Parent.DrawingObjects.Delete 'supprime le bouton
    With .Parent.UsedRange: End With 'actualise
End With
Set d = CreateObject("Scripting.Dictionary")
For i = 2 To nlig
    d(UCase(tablo(i, colref))) = "" 'valeurs uniques en colonne B
Next i
a = d.keys
ReDim resu(1 To nlig, 1 To ncol)
For i = 0 To UBound(a)
    cle = a(i)
    n = 0
    For j = 2 To nlig
        If tablo(j, colref) = cle Then
            n = n + 1
            For k = 1 To ncol
                resu(n, k) = tablo(j, k)
            Next k
        End If
    Next j
    LO.Parent.Copy '2ème document auxiliaire
    With ActiveSheet.ListObjects(1).Range
        .ListObject.Resize .Resize(n + 1) 'redimensionne le tableau structuré
        .Cells(2, 1).Resize(n, ncol) = resu 'restitue le tableau des résultats
    End With
    ThisWorkbook.Sheets("Appendice").Copy After:=ActiveSheet 'ajoute la feuille Appendice
    Sheets(1).Activate
    If Trim(a(i)) = "" Then a(i) = "(vide)"
    ActiveWorkbook.SaveAs chemin & a(i) & ".xlsx", 51 'enregistre le fichier
    ActiveWorkbook.Close 'ferme le fichier créé
Next i
LO.Parent.Parent.Close False 'ferme le 1er document auxiliaire
MsgBox UBound(a) + 1 & " fichier" & IIf(UBound(a), "s .xlsx ont été créés...", " .xlsx a été créé...")
End Sub

Edit : b = d.items n'est plus nécessaire.

A+