Discussion :

[Gilles777]

Bonjour à tous

je dispose d'un onglet avec 3 champs (qui est aussi une liste)



je souhaiterais pouvoir lancer une macro
1) qui crée les fichiers Excel dans les répertoires mentionnés (3 fichiers dans 2 répertoires dans le cas ci dessus)
2) et dans chaque fichier il y aura un onglet comprenant les données respectives de la colonne "Valeurs"

merci pour vos idées

[Philippe Tulliez]

Bonjour,
Pour créer un répertoire, on peut utiliser la fonction MkDir en vérifiant auparavant son existence avec Dir ou bien avec le FileSystemObject voir le lien

Exemple avec MkDir et Dir

Code :

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

1
2
3
4
5
6
7
8
9
Sub t()
  Dim CurrentPath As String
  Dim SubFolder As String
  Dim FullPath As String
  CurrentPath = ThisWorkbook.Path  ' Nom du répertoire courant de l'application
  SubFolder = "TinTin"             ' Nom du sous-dossier à créer
  FullPath = CurrentPath & "\" & SubFolder
  If Dir(FullPath, vbDirectory) = "" Then MkDir FullPath
End Sub

La méthode Add de la collection Workbooks permet d'ouvrir un nouveau classeur. Exemple : Workbooks.Add
Une fois créé, il devient le classeur actif (ActiveWorkbook) et à l'aide de la méthode SaveAs de celui-ci et en lui passant les bonnes valeurs à ses arguments, on pourra donc l'enregistrer

[Franc]

Salut, voici une possibilité, à adapter si nécessaire:

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
Sub CopierValeurs()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim wb As Workbook
    Dim destWs As Worksheet
    Dim destCell As Range
    Dim chemin As String
    Dim fichier As String
 
    Application.ScreenUpdating = False
 
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" si nécessaire
    Set rng = ws.Range("A2:A" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row)
 
    For Each cell In rng
        chemin = cell.Offset(0, 1).Value
        fichier = cell.Offset(0, 2).Value
 
        If cell.Value <> "" Then
            ' Ouvrir le classeur de destination
            On Error Resume Next ' Ignorer l'erreur si le fichier n'existe pas
            Set wb = Workbooks.Open(chemin & fichier)
            On Error GoTo 0 ' Réactiver les erreurs
 
            ' Si le classeur de destination n'existe pas, le créer
            If wb Is Nothing Then
                Set wb = Workbooks.Add
                wb.SaveAs chemin & fichier
            End If
 
            ' Définir la feuille de travail et la cellule de destination
            Set destWs = wb.Sheets(1)
            Set destCell = destWs.Range("A" & destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1)
 
            ' Copier la valeur dans la cellule de destination
            destCell.Value = cell.Value
 
            ' Sauvegarder et fermer le classeur de destination
            wb.Close SaveChanges:=True
            Set wb = Nothing
        End If
    Next cell
 
    Application.ScreenUpdating = True
 
    MsgBox "Traitement terminé!", vbInformation
 
End Sub

[EDIT] Comme je n'étais pas très satisfait de ma première macro, qui éffectue des opérations d'ouverture/fermeture de fichier pour chaque cellule, je l'ai retravaillée. Maintenant il n'y a plus qu'une ouverture/fermeture par groupe de cellules ayant le même chemin et fichier.
Résultat pour traiter 100 cellules avec la première macro: 68 secondes, avec la 2è version: 2.1 secondes. A toi de choisir.

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
Sub CopierValeurs2()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim wb As Workbook
    Dim destWs As Worksheet
    Dim destCell As Range
    Dim chemin As String
    Dim fichier As String
    Dim dict As Object
    Dim key As Variant
    Dim values As Object
    Dim value As Variant
 
    ' Désactiver l'affichage des fenêtres
    Application.ScreenUpdating = False
 
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" si nécessaire
    Set rng = ws.Range("A2:A" & ws.Cells(ws.Rows.Rows.Count, "A").End(xlUp).Row)
 
    ' Créer un dictionnaire pour regrouper les valeurs par fichier
    Set dict = CreateObject("Scripting.Dictionary")
 
    ' Parcourir chaque cellule de la plage
    For Each cell In rng
        chemin = cell.Offset(0, 1).value
        fichier = cell.Offset(0, 2).value
        If cell.value <> "" Then
            ' Créer la clé du dictionnaire
            key = chemin & fichier
 
            ' Ajouter la valeur à la liste pour cette clé
            If dict.Exists(key) Then
                dict(key).Add cell.value
            Else
                Set dict(key) = CreateObject("System.Collections.ArrayList")
                dict(key).Add cell.value
            End If
        End If
    Next cell
 
    ' Parcourir chaque clé du dictionnaire
    For Each key In dict.Keys
        ' Ouvrir le classeur de destination
        On Error Resume Next ' Ignorer l'erreur si le fichier n'existe pas
        Set wb = Workbooks.Open(key)
        On Error GoTo 0 ' Réactiver les erreurs
 
        ' Si le classeur de destination n'existe pas, le créer
        If wb Is Nothing Then
            Set wb = Workbooks.Add
            wb.SaveAs key
        End If
 
        ' Définir la feuille de travail et la cellule de destination
        Set destWs = wb.Sheets(1)
        Set destCell = destWs.Range("A" & destWs.Cells(destWs.Rows.Count, "A").End(xlUp).Row + 1)
 
        ' Copier les valeurs dans les cellules de destination
        Set values = dict(key)
        For Each value In values
            destCell.value = value
            Set destCell = destCell.Offset(1, 0)
        Next value
 
        ' Sauvegarder et fermer le classeur de destination
        wb.Close SaveChanges:=True
        Set wb = Nothing
    Next key
 
    Application.ScreenUpdating = True
 
    MsgBox "Traitement terminé!", vbInformation
 
End Sub

[Gilles777]

Merci Franc

ça fonctionne parfaitement, je vais l'adapter (rajouter les titres et des colonnes de valeur)

[Gilles777]

Bonjour Franc

en fait je n'arrive pas à généraliser, j'essaie de travailler sur plusieurs colonnes de valeur, ça peut être 2, voire 3, 4, 5...


j'ai remplacé la formule de sélection de rng par

Code :

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

Set rng = ws.Range("A2:B" & ws.Cells(ws.Rows.Rows.Count, "A").End(xlUp).Row)

pour ce qui est du nombre de lignes rester sur la colonne A ça va bien; mais y aurait il une formulation plus générique , qui sélectionnerait toutes les colonnes de valeur (Valeur1, 2, 3, 4,5...) - sans bien sûr les 2 dernières colonnes qui comprennent le nom du répertoire et du fichier
J'imagine qu'il faut créer une variable pour stocker le nombre de colonnes de valeurs, et ce, pour

Code :

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

1
2
3
For Each cell In rng
        chemin = cell.Offset(0, NbCol+1).value
        fichier = cell.Offset(0, NbCol+2).value

ensuite quand on stocke

Code :

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

dict(key).Add cell.value

, il faudrait quelque part aussi indiquer la ligne et la colonne

et enfin quand on copie les valeurs dans les cellules de destination il faudrait le faire en fonction des lignes et des colonnes initiales

cerise sur le gâteau il faudrait copier la première ligne de titres aussi dans chaque fichier cible, j'imagine qu'il faut créer un Dict2 ?

Voilà, si tu as un peu de "temps de cerveau disponible" ça m'aiderait bien

[Franc]

Salut, en espérant avoir bien compris ta demande, teste ceci:

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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Sub CopierValeurs()
    Dim ws As Worksheet
    Dim rng As Range
    Dim cell As Range
    Dim wb As Workbook
    Dim destWs As Worksheet
    Dim destCell As Range
    Dim dict As Object
    Dim key As Variant
    Dim values As Object
    Dim value As Variant
    Dim NbCol As Long
    Dim i As Long
 
    ' Désactiver l'affichage des fenêtres
    Application.ScreenUpdating = False
 
    Set ws = ThisWorkbook.Sheets("Feuil1") ' Remplacez "Feuil1" si nécessaire
    NbCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column - 2 ' Nombre de colonnes de valeurs
    Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(ws.Rows.Count, "A").End(xlUp).Resize(, NbCol))
 
    ' Créer un dictionnaire pour regrouper les valeurs par fichier
    Set dict = CreateObject("Scripting.Dictionary")
 
    ' Parcourir chaque cellule de la plage
    For Each cell In rng
        If cell.value <> "" Then
            ' Créer la clé du dictionnaire
            key = ws.Cells(cell.Row, NbCol + 1).value & ws.Cells(cell.Row, NbCol + 2).value
 
            ' Ajouter la valeur à la liste pour cette clé
            If dict.Exists(key) Then
                dict(key).Add cell.Address(False, False) & ":" & cell.value
            Else
                Set dict(key) = CreateObject("System.Collections.ArrayList")
                dict(key).Add cell.Address(False, False) & ":" & cell.value
            End If
        End If
    Next cell
 
    ' Parcourir chaque clé du dictionnaire
    For Each key In dict.Keys
        ' Ouvrir le classeur de destination
        On Error Resume Next ' Ignorer l'erreur si le fichier n'existe pas
        Set wb = Workbooks.Open(key)
        On Error GoTo 0 ' Réactiver les erreurs
 
        ' Si le classeur de destination n'existe pas, le créer
        If wb Is Nothing Then
            Set wb = Workbooks.Add
            wb.SaveAs key
        End If
 
        ' Définir la feuille de travail et la cellule de destination
        Set destWs = wb.Sheets(1)
 
        ' Copier les titres dans le classeur de destination
        If destWs.Cells(1, 1).value = "" Then
            ws.Range(ws.Cells(1, 1), ws.Cells(1, NbCol)).Copy destWs.Cells(1, 1)
        End If
 
        ' Copier les valeurs dans les cellules de destination
        Set values = dict(key)
        For Each value In values
            Set destCell = destWs.Range(Split(value, ":")(0))
            destCell.value = Split(value, ":")(1)
        Next value
 
        ' Sauvegarder et fermer le classeur de destination
        wb.Close SaveChanges:=True
        Set wb = Nothing
    Next key
 
    Application.ScreenUpdating = True
 
    MsgBox "Traitement terminé!", vbInformation
 
End Sub