Discussion :

[jean_baptiste_clem]

Bonjour,

Je vous consulte pour être guidé dans la résolution d'un problème pratique qui nous prend beaucoup d'énergie dans mon service, faute d'avoir trouvé la solution qui automatiserait le tout.

Nous recevons régulièrement un fichier excel de plusieurs milliers de lignes, et qui recense les choix de formation des agents de la collectivité.

Le tout se présente sous la forme nom / prénom / email / formation choisie.

Ensuite débute une tâche très pénible qui devrait pouvoir être automatisée, parce qu'à la main c'est une tannée :

- Créer un dossier par choix de formation recensée
- Dans chaque dossier, enregistrer un fichier nom / prénom / email / formation choisie (mais juste la liste des gens qui ont choisi la formation dont le dossier porte le nom) en .csv séparé par virgule

J'imaginais un dispositif qui prendrait pour départ la cellule D2 ( formation choisie) et qui ferait une boucle du type :

- Crée un dossier dont le nom est le contenu de la cellule D2
- Enregistre en .csv séparé par virgule, dans le dossier dont le nom est le contenu de la cellule D2, les lignes dont la cellule D est identique au contenu de la cellule D2
- Supprime les lignes dont la cellule D est identique au contenu de la cellule D2

De cette façon, on arriverait vite à la fin du tableau

Par contre, je ne sais pas si VBA ferait ce type d'opération. Je suis parti sur VBa parce que Excel, mais j'aimerais avoir votre avis.

Qu'en pensez-vous ?

Merci à vous d'avoir lu jusqu'ici !

Jean-Baptiste

[jean_baptiste_clem]

Il suffit de créer une liste sans doublon des formations demandées en utilisant la formule =unique, puis en sélectionnant la liste ainsi obtenue et en utilisant le code suivant

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub MakeFolders()
Dim Rng As Range
Dim maxRows, maxCols, r, c As Integer
Set Rng = Selection
maxRows = Rng.Rows.Count
maxCols = Rng.Columns.Count
For c = 1 To maxCols
r = 1
Do While r <= maxRows
If Len(Dir(ActiveWorkbook.Path & "\" & Rng(r, c), vbDirectory)) = 0 Then
MkDir (ActiveWorkbook.Path & "\" & Rng(r, c))
On Error Resume Next
End If
r = r + 1
Loop
Next c
End Sub

Pour la suite je cherche encore

[Franc]

Bonjour, voici mon approche en considérant qu'il y a des entêtes de A1 à D1:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Sub ExportData()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim folderPath As String
    Dim fileName As String
    Dim participantName As String
    Dim dict As Object
    Dim key As Variant
 
    'Définit la feuille de calcul active comme la première feuille dans le classeur actif
    Set ws = ThisWorkbook.Sheets(1)
 
    'Détermine la dernière ligne de données en recherchant la dernière cellule non vide dans la colonne A
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
 
    'Définit le chemin d'accès au dossier de destination
    folderPath = "C:\Chemin\vers\le\dossier\de\destination\"
 
    'Crée un nouveau dictionnaire
    Set dict = CreateObject("Scripting.Dictionary")
 
    ' Stocke les choix de formation uniques dans un dictionnaire
    For i = 2 To lastRow
        'Récupère le nom du dossier de destination à partir de la colonne D
        fileName = ws.Cells(i, "D").Value
        'Vérifie si le nom du dossier existe déjà dans le dictionnaire. Si ce n'est pas le cas, ajoutez-le.
        If Not dict.Exists(fileName) Then
            dict.Add fileName, 0
        End If
    Next i
 
    ' Crée des dossiers pour chaque choix de formation
    For Each key In dict.Keys
        'Vérifie si le dossier de destination existe déjà. Si ce n'est pas le cas, créez-le.
        If Len(Dir(folderPath & key, vbDirectory)) = 0 Then
            MkDir folderPath & key
        End If
    Next key
 
    'Itère à travers chaque ligne de données, en commençant par la deuxième ligne (la première ligne contient les en-têtes de colonne)
    For i = 2 To lastRow
        'Récupère le nom du dossier de destination à partir de la colonne D
        fileName = ws.Cells(i, "D").Value
        'Crée le nom du fichier CSV en combinant le nom et le prénom du participant
        participantName = ws.Cells(i, "A").Value & "_" & ws.Cells(i, "B").Value
        'Ouvre un fichier CSV pour écrire les données
        Open folderPath & fileName & "\" & participantName & ".csv" For Output As #1
        'Écrit les en-têtes de colonne dans le fichier CSV
        Print #1, "Nom,Prénom,Email,Formation choisie"
        'Écrit les données du participant dans le fichier CSV
        Print #1, ws.Cells(i, "A").Value & "," & ws.Cells(i, "B").Value & "," & ws.Cells(i, "C").Value & "," & ws.Cells(i, "D").Value
        Close #1
 
    Next i
 
    MsgBox "Terminé!"
End Sub

[Philippe Tulliez]

Bonjour,
Une autre approche en utilisant la méthode AdvancedFilter de l'objet Range à la fois pour exporter les données et créer la liste unique.

La procédure SplitColumn crée une liste unique des données contenue dans la colonne nommée Département en invoquant la fonction GetUniqueRange et exporte ensuite les lignes correspondant à chaque département en créant un nouveau classeur et en le sauvant sous format csv en le nommant du nom du département et en créant un sous-dossier éponyme si celui n'existe pas. Si le fichier existe déjà, il est écrasé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
Sub SplitColumn()
  ' Déclaration et affectation des variables et contantes
  Const LabelSplit As String = "Département"  ' Nom de la colonne dont on extrait les valeurs uniques
  Const SheetName As String = "db"            ' Nom de la feuille où se trouve la table
  Dim sht As Worksheet
  Dim rngSource As Range
  Dim rngUnique As Range
  Dim c As Integer
  Dim Name As String
  Dim NewPath As String
  Dim FullName As String
  ' Plage source
  Set rngSource = ThisWorkbook.Worksheets(SheetName).Range("A1").CurrentRegion
  ' *** Début ***
  Application.ScreenUpdating = False
  ' Plage de données avec les valeurs uniques
  Set rngUnique = GetUniqueRange(rngSource, LabelSplit)
  For c = 1 To rngUnique.Rows.Count - 1
    Worksheets.Add                       ' Crée une nouvelle feuille pour exporter les données
    ' *** Exporte les données
    With ActiveSheet
     rngSource.AdvancedFilter Action:=xlFilterCopy, _
                              CriteriaRange:=rngUnique.Resize(2), _
                              CopyToRange:=.Range("A1")
    .Move ' Déplacement de la feuille
    End With
    ' *** Sauve le classeur en csv
    With ActiveWorkbook
     Name = rngUnique.Offset(1).Resize(1)
     NewPath = ThisWorkbook.Path & "\" & Name
     If Len(Dir(NewPath, vbDirectory)) = 0 Then MkDir NewPath
     Application.DisplayAlerts = False
    .SaveAs FileName:=NewPath & "\" & Name & ".csv", FileFormat:=xlCSVUTF8, CreateBackup:=False
     Application.DisplayAlerts = True
    .Close
    End With
    rngUnique.Offset(1).Resize(1).Delete ' Supprime la donnée unique utilisée
  Next
  rngUnique.Clear
  Application.ScreenUpdating = True
  Set rngSource = Nothing: Set rngUnique = Nothing: Set sht = Nothing
End Sub

Code de la fonction GetUniqueRange qui crée la liste sans doublons

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Function GetUniqueRange(oRange As Range, Label As String)
  ' Crée une colonne unique 2 colonnes à droite de oRange
  ' oRange   Source des données
  ' Label    Etiquette de colonne dont on doit extraire les éléments uniques
  Dim t As Range
  With oRange
   Set t = .Offset(ColumnOffset:=.Columns.Count + 1).Resize(1, 1)
   t.Value = Label
   .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=t, Unique:=True
  End With
  Set GetUniqueRange = t.CurrentRegion
  Set t = Nothing
End Function

Illustration de la liste partielle des données utilisée pour le test

[jean_baptiste_clem]

Finalement j'ai juste essayé la réponse de Franc, merci à vous deux

[jean_baptiste_clem]

J'ai un peu galéré en oubliant d'enlever les caractères spéciaux de mes noms de formation, mais dès que j'ai fait ça il m'a tout fait nickel, merci !