Macro création de classeurs multiples nommés

Version imprimable

Bonjour à tous!

J'ai un fichier contenant une liste de noms en colonne C et sur chaque ligne le nom est suivi de caractéristiques. Je veux créer une maccro qui pour chaque ligne va créer un nouveau classeur et entrer les caractéristiques dans ce classeur.
La partie "copie des données d'un classeur à un autre" j'ai trouvé beaucoup d'infos dessus alors je pourrai peut-être m'en sortir. Mon problème actuellement c'est que je n'arrive pas à créer ces classeurs nommés.

Mon code ressemble à ça:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 Sub creationCRApapier() Dim NoLign1 As Integer Dim NewBook As Workbook For NoLign1 = 8 To 48 If Cells(NoLign1, 3).Value <> 0 Then Set NewBook = Workbooks.Add 'creation NewBook.SaveAs "C:\chemin\cells(nolign1,3).value.xlsm" End If Next End Sub
Le problème c'est que évidemment cells(nolign1,3).value ne renvoie pas la valeur de la cellule ici, il essaie d'enregistrer un classeur qui s'appelle comme ça. J'ai essayé aussi d'écrire: NewBook.SaveAs "C:\chemin\"&cells(nolign1,3).value&".xlsm" mais sans succés

Je ne sais pas s'il est possible d'enregistrer plusieurs classeurs successifs en fonction de la valeur d'une cellule, mais c'est ce que j'essaie de faire :)

Merci d'avance!

Salut, à tester

Code:

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
Option Explicit
 
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
                                             (ByVal hwnd As Long, _
                                              ByVal pszPath As String, _
                                              ByVal lngsec As Long) As Long
 
Private Function CreationDossier(sDossier) As Long
Dim Rep As Long
    Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
 
Sub creationCRApapier()
Dim NoLign1 As Long, NewBook As Workbook
Dim sDossier As String, iCpt As Long
    iCpt = 0
    Application.StatusBar = ""
    sDossier = ThisWorkbook.Path & "\" & "Essais"
    CreationDossier sDossier
 
    Application.ScreenUpdating = False
    For NoLign1 = 8 To 48
        If Feuil1.Cells(NoLign1, 3).Value <> 0 Then
            Set NewBook = Workbooks.Add
            Application.DisplayAlerts = False
            With NewBook
                .SaveAs sDossier & "\" & Feuil1.Cells(NoLign1, 3).Text & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
                .Close
            End With
            iCpt = iCpt + 1
            Application.DisplayAlerts = True
            Set NewBook = Nothing
        End If
        Application.StatusBar = iCpt
    Next NoLign1
    Application.ScreenUpdating = True
End Sub

18/04/2017, 11h20
Pierre Fauconnier

Salut.

Tu dois recomposer la chaine du nom en concaténant tes portions de chaine.

Code:

NewBook.SaveAs "C:\chemin\" & cells(nolign1,3).value & ".xlsm"
18/04/2017, 11h51
flagpara

Bonjour,

comme je l'ai dit dans mon premier message, c'est la première chose que j'ai essayé mais sans succés, j'ai réessayé en copiant ton code au cas où, j'obtiens une erreur 1004.

Je vais essayer la solution de kiki29, il va juste me falloir un peu de temps pour la comprendre ^^'
18/04/2017, 11h57
Pierre Fauconnier

Si cela ne fonctionne pas, c'est que la valeur de la cellule (par exemple C8) ne contient pas une valeur qui, collée au reste, donne un nom de chemin valide, par exemple parce que c:\chemin\ n'est pas un chemin valide.

Peut-être dois-tu aussi récupérer le chemin du fichier au travers d'une variable, mais dans ton code, ça ne transparait pas de façon limpide.

Cela dit, tu aurais intérêt à sortir ton chemin de ton code et à le mettre dans une cellule, le hard-coding (Mettre une donnée en dur dans le code), ce n'est jamais la bonne solution.
18/04/2017, 12h02
flagpara

Effectivement Pierre Fauconnier le hard coding était sans doute ce qui posait problème, ça et le contenu des cellules.

Cela-dit la solution de kiki29, après une ou deux modifications, est parfaite! Merci beaucoup tu viens de m'enlever une belle épine du pied je n'en demandais pas tant :lol:

Bonne journée et merci pour votre aide!