Discussion :

[Astumap]

Bonjour,

Je vous explique le problème.
J'ai un fichier sur lequel il y a une liste de contacts. On a une colonne avec leur nom et prénom, une avec des infos et une avec le chemin d'accès (récupéré par macro) qui mène au dossier serveur.
Chaque contact peut avoir plusieurs infos, donc un même contact peut s'étaler sur 10 lignes par exemple.

Ce que je souhaite arriver à faire, c'est créer un petit fichier excel pour chaque contact, en récupérant ses infos et enregistrer celui-ci dans le chemin du dossier du contact.

J'ai trié la liste par nom et prénom. Dans la colonne chemin répertoire, j'ai fait une formule pour que le chemin s'affiche sur la première ligne du contact, que sur les lignes suivantes ce soit vide et que sur la dernière ligne du contact concerné, il soit écrit "stop".

Il faudrait que la macro découpe cette liste après chaque "stop", pour créer le petit fichier excel et l'enregistrer. Seulement là je suis bien au-delà de mes compétences et c'est pour cela que je fais appel à vous. J'ai déjà du code pour créer un nouveau fichier excel, mais ce qui me bloque c'est surtout le découpage...

Merci d'avance !

[Kimy_Ire]

Fichier exemple ?

[Astumap]

Du fait de la confidentialité des données, je ne peux mettre le fichier en ligne (et de plus il est très volumineux).
Je vous ai donc crée un bref exemple bidon, pour aperçu.

[Kimy_Ire]

Dans "Fichier exemple" il y a le mot exemple !

Bref, ce que tu veux c'est exporter les données que tu as donné dans un fichier excel pour chaque nom et prénom ? C'est à dire faire du copier coller de toutes tes lignes qui ont le même nom et prénom et créer des fichiers excel correspondant à ces noms et prénoms ?

Veux-tu créer un fichier unique dans lequel tu placerais tes données en lignes pour chaque nom et prénom ?

Bref, exprime de manière plus précise ce que tu souhaites car je n'ai pas bien compris... personnellement...

PS : quand je parlais d'un fichier exemple c'est sur l'onglet 1 ce que tu donnes (c'est à dire le fichier "origine") et dans un second onglet, ce que tu souhaites obtenir.

**************************************************************
Autre chose : je n'ai pas bien compris le mécanisme que tu voulais utiliser avec tes "stop". Tu peux directement en colonne D écrire sur toutes les lignes quelque chose comme cela "=SI(A12<>A13; "stop"; "")" (ici en ligne 12 par exemple).
Pourquoi réécrire le chemin ? Est-ce utile dans ton fichier d'origine ?

[Astumap]

C'est pas faux

Voilà j'ai mis en PJ le fichier complété avec un deuxième onglet pour ce que je voudrais avoir.

Ce que j'imagine, c'est une macro avec boucle qui, à partir de la feuille "contacts_archiv", repérerait chaque contact (peu importe le nombre de lignes, tant que c'est le même contact) et qu'elle copie/colle les données du contact (comme présentées sur l'onglet "resultat") pour un nouveau fichier excel, qui irait s'enregistrer dans le répertoire du contact concerné (grâce au chemin fourni dans la première feuille).

Je crois que le mot "complexe" est approprié !

Et ici l'exemple de code que j'avais trouvé sur internet pour créer un fichier excel et l'enregistrer dans un répertoire donné :

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
Sub FichierExcel()
Dim XL As Object, WK As Object
Set XL = CreateObject("Excel.Application")
Set WK = XL.Workbooks.Add(&HFFFFEFB9)
With WK
With .Worksheets(1&)
.[A1] = 3&
.[A1:A10].DataSeries , , , 2&
.[B1] = 2&
.[B1:B10].DataSeries , , , 3&
.[D5].Formula = "=SUMPRODUCT((A1:A10>10)*(B1:B10<20))"
End With
.SaveAs CurDir & XL.PathSeparator & "MonFichierCreer.xls"
.Close
End With
XL.Quit
Set WK = Nothing
Set XL = Nothing
End Sub

Après j'avais pensé remplacer CurDir par une variable.
Exemple :

Code :

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

Chemin = Sheets("contacts_archiv").Range("D" & Suite).Value

Avec Suite qui tournerait dans la boucle Suite = Suite + 1 pour aller chercher les autres chemins.
Mais honnêtement je suis paumé, faudrait déjà arriver à caler ce que j'appellais plus haut le découpage. Pas évident tout ça...

Je pars en congés là pour la semaine de Noël, je reviens donc le 31 pour reprendre ce topic et essayer de trouver une solution avec ceux qui voudront bien m'aider !

Merci et bonnes fêtes !

[Kimy_Ire]

Voila le code que je te propose :

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
Sub save()
Dim test As Range
Dim cell_des As Range
Dim table() As String
Dim j As Integer
 
With Worksheets("contacts_archiv")
    Set test = .Range("A1")
    For i = 1 To .Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row - 1
        ReDim table(1 To 1)
        If test.Offset(i, 0) <> test.Offset(i - 1, 0) Then
            j = 0
            Do
                ReDim Preserve table(1 To j + 1)
                table(j + 1) = test.Offset(i + j, 1).Value
                j = j + 1
            Loop Until test.Offset(i + j, 0).Value <> test.Offset(i, 0).Value
            AddNewWorkbook test.Offset(i, 0), table
        End If
    Next i
 
End With
 
End Sub
 
 
Function AddNewWorkbook(rng As Range, table() As String)
Dim xlApp As Excel.Application
Dim workb As Workbook
Dim xlSheet As Excel.Worksheet
 
Dim strt As Integer
Dim cell_des As Range
Dim msg As String
 
Set xlApp = CreateObject("Excel.Application")
xlApp.SheetsInNewWorkbook = 1
Set workb = Application.Workbooks.Add
workb.SaveAs Filename:=rng.Offset(0, 2).Value
xlApp.Visible = True
Set xlSheet = workb.Worksheets(1)
xlSheet.name = rng.Value
 
 
With ActiveWorkbook.Worksheets(rng.Value)
    Set cell_des = .Range("A1")
    cell_des = "Contact"
    cell_des.Font.Bold = True
    cell_des.Offset(0, 1) = "Infos"
    cell_des.Offset(0, 1).Font.Bold = True
    For i = 1 To UBound(table)
        cell_des.Offset(i, 0) = rng.Value
        cell_des.Offset(i, 1) = table(i)
    Next i
End With
 
ActiveWorkbook.Close SaveChanges:=True
 
xlApp.Quit
 
End Function

Dis moi si ça te convient et s'il fonctionne correctement. Chez moi, c'est bon !
Il n'est pas très optimisé mais fonctionne. J'espère que la macro ne prendra pas trop de temps.

[Astumap]

Bonjour,

Je viens de découvrir ta réponse, alors déjà je te remercie beaucoup pour ton investissement !
J'ai testé ton code, chapeau, le découpage fonctionne à merveille et les fichiers sont crées et enregistrés !
Il y a juste un petit truc qui manque, ils ne vont pas s'enregistrer dans leur dossier respectif, ils se mettent tous dans le dossier TEST.
Or c'est dans ce dossier TEST qu'on a les sous-dossiers de chaque contact (comme présenté via le lien sur le fichier, colonne C "Chemin").

J'ai essayé de comprendre ta macro (plutôt que de copier bêtement) mais je ne vois pas bien comment tu fais pour dire aux nouveaux fichiers de s'enregistrer dans tel répertoire. Et tu te sers de quelle colonne, la E ? Je vois dans la fonction comment tu nommes le fichier pour l'enregistrer mais je ne trouve pas le chemin.

Merci pour ta patience !

[Kimy_Ire]

Avec les commentaires :

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
79
80
81
82
83
84
85
86
87
88
'Nom de la macro
Sub save()
'Déclaration des variables
Dim test As Range
Dim cell_des As Range
Dim table() As String
Dim j As Integer
 
'On travaille dans la feuille "contacts_archiv"
With Worksheets("contacts_archiv")
    'On set test sur la cellule "A1"
    Set test = .Range("A1")
 
    'On boucle de 1 au nombre de lignes qu'on trouve dans la colonne 1 (ou A) - 1
    For i = 1 To .Columns(1).Find("*", , , , xlByColumns, xlPrevious).Row - 1
        'On redimentionne notre tableau en effacant toutes les données comprises dedant
        ReDim table(1 To 1)
        'Le test se situe ici : si test.Offset(i, 0) (c-a-d test avec un offset de i ligne(s) ) est différent de la ligne suivante alors...
        If test.Offset(i, 0) <> test.Offset(i - 1, 0) Then
            'On set j à 0
            j = 0
            'Et on execute jusqu'à ce que test.Offset(i + j, 0) est différent de test.Offset(i, 0) (voir "Loop Until") le code suivant :
            Do
                'On redimensionne notre tableau en préservant son contenu
                ReDim Preserve table(1 To j + 1)
                'On ajoute à notre tableau la valeur contenu à droite de test test.Offset(i + j, 0) c'est à dire la colonne "Infos"
                table(j + 1) = test.Offset(i + j, 1).Value
                'On incrémente j
                j = j + 1
            Loop Until test.Offset(i + j, 0).Value <> test.Offset(i, 0).Value
 
            'Enfin, on appelle la fonction "AddNewWorkbook" lorsque le tableau est "plein" avec les paramètres "test.Offset(i, 0)" et "table"
            AddNewWorkbook test.Offset(i, 0), table
        End If
    Next i
 
End With
 
 
End Sub
 
'La fonction "AddNewWorkbook" :
Function AddNewWorkbook(rng As Range, table() As String)
 
'Déclaration des variables
Dim xlApp As Excel.Application
Dim workb As Workbook
Dim xlSheet As Excel.Worksheet
 
Dim strt As Integer
Dim cell_des As Range
Dim msg As String
 
'Création du fichier excel
Set xlApp = CreateObject("Excel.Application")
xlApp.SheetsInNewWorkbook = 1
Set workb = Application.Workbooks.Add
'Ici on sauvegarde le fichier à la localisation qui se trouve dans la colonne C. (C'est ce que j'avais compris...)
workb.SaveAs Filename:=rng.Offset(0, 2).Value
xlApp.Visible = True
'On assigne à ce nouveau fichier un seul onglet...
Set xlSheet = workb.Worksheets(1)
'...qu'on nomme comme la colonne A.
xlSheet.name = rng.Value
 
 
'Avec ce nouveau classeur
With ActiveWorkbook.Worksheets(rng.Value)
    'On insère les titres
    Set cell_des = .Range("A1")
    cell_des = "Contact"
    cell_des.Font.Bold = True
    cell_des.Offset(0, 1) = "Infos"
    cell_des.Offset(0, 1).Font.Bold = True
 
    'Et on place toutes les infos qu'on avait dans la colonne Infos
    For i = 1 To UBound(table)
        cell_des.Offset(i, 0) = rng.Value
        cell_des.Offset(i, 1) = table(i)
    Next i
End With
 
'On sauvegarde le fichier et on le ferme.
ActiveWorkbook.Close SaveChanges:=True
 
'xlApp.Quit
 
End Function

Je ne comprends pas où tu veux sauvegarder tes fichiers si ce n'est à l'emplacement qui est dans la colonne C.

[Astumap]

Salut, merci pour l'ajout des commentaires.
J'ai retenté mais ça ne fonctionne toujours pas, les fichiers vont s'enregistrer dans TEST mais pas dans leur dossier respectif (celui de la colonne C comme tu l'avais bien compris).
Voir capture1 pour que tu vois ce que ça donne.

Par ailleurs, j'ai renommé Sub save() en Sub testsave() car sinon j'avais un message d'erreur. Voir capture2.

En fait, je ne comprenais pas cette ligne :

Code :

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

workb.SaveAs Filename:=rng.Offset(0, 2).Value

Parce que je croyais que Filename servait juste à donner le nom au fichier, mais il est effectivement dit dans l'aide que l'on peut inclure un chemin complet (sinon Excel enregistre le fichier dans le dossier actif).
Donc je pense que c'est à ce niveau là qu'il y a une mauvaise interprétation d'Excel, non ? Ca marche correctement chez toi ?

[Kimy_Ire]

Avec un peu de recherche tu aurais largement pu réussir :

Code :

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

workb.SaveAs Filename:=rng.Offset(0, 2).Value & "\" & rng.Value

Bref, j'espère ça t'aidera !

[Astumap]

Ah effectivement j'aurais pu trouver et pourtant c'est pas faute d'avoir cherché, je me complique un peu trop je pense...
Je comprends maintenant pourquoi il mettait tout dans TEST, il se basait par rapport au dernier "\". Enfin au moins ce n'est pas quelque chose que j'oublierai à l'avenir !

Je te remercie énormément pour ton aide, ça fonctionne nickel, je vais désormais adapter tout ceci à mon vrai fichier.

A+ !