[Résolu] creation auto. de fichier excel avec repertoire

[Laosurlamontagne]

Bonjour à tous,

J'aurais un truc complétement barré à vous soumettre...

Je dispose d'une base de donnée de produit avec leurs caractéristiques que je souhaite extraire en fichiers excel individuels (1 par produit) dans des répertoires portant le nom du produit. Comme le nombre est important (>100), je voudrais passer par une macro pour gagner du temps.
Le fichier joint décrit ce que je voudrais faire.

Le premier onglet est ma base de donnée, le second est le fichier excel de sortie recherché. Je voudrais que ce fichier Excel porte le nom du produit ET qu'il soit placé dans un répertoire du même nom... Et ainsi de suite pour les autres ligne de la base de donnée.

Auriez-vous une idée?

Merci pour votre aide.

Gg

 

[Lone-wolf]

Re : [non résolu] creation auto. de fichier excel avec repertoire

Bonjour Laosurlamontagne,

Il y avait un beau châlet???

Trêve de plaisenterie

regarde si le code correspond à tes souhaits. Bienentendu, il faut que tu fasse certaines modifications.

Option Explicit
Private Declare PtrSafe Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
Public t As Double, i&, nomdeb$, Rep$, chemin$, derl&
Private Sub CreationDossier(sNomRep As String)
SHCreateDirectoryEx 0&, sNomRep, 0&
End Sub

Sub Creer_Dossier()
Dim WordApp As Word.Application, WordDoc As Word.Document
Dim xlApp As New Excel.Application, xlBook As Workbook, NomFichier As String
Dim rg, nFile, tmp, a, b

Sheets(1).Activate
derl = ActiveSheet.Range("A65536").End(xlUp).Row
nomdeb = "C:\Documents Privés\"      'Crée le dossier


'Ensuite les sous-dossiers et les fichiers
On Error Resume Next

For i = 2 To derl
Application.GoTo ActiveSheet.Range("A" & i)

    Rep = ActiveCell.Value
    CreationDossier nomdeb & Rep & "\"
    chemin = nomdeb & Rep & "\" & ActiveSheet.Range("B1").Value & ".doc"
    NomFichier = nomdeb & Rep & "\" & ActiveSheet.Range("B1").Value

With Worksheets("Feuil1")
rg = Rep
End With
nFile = NomFichier & ".txt"
Open nFile For Output As #1
For a = 1 To UBound(rg, 1)
tmp = " "
For b = 1 To UBound(rg, 2)
If tmp > "" Then
tmp = tmp & Chr(34) & rg(a, b) & Chr(34)
Else
tmp = rg(a, b)
End If
Next
Print #1, tmp
Next
Close #1

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
xlBook.SaveAs NomFichier & " - " & ActiveSheet.Range("A" & i).Value
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
    Set WordDoc = WordApp.Documents.Add

    With WordApp.Selection
    .Text = ActiveSheet.Range("B2").Value & i
    .ParagraphFormat.Alignment = wdAlignParagraphRight
    .Font.Name = "Verdana"
    .Font.Size = 9
    .Font.Bold = True
End With
With WordDoc.Sections(1)
        .Footers(wdHeaderFooterPrimary).Range.Text = chemin
        .Footers(wdHeaderFooterPrimary).Range.Paragraphs.Alignment = wdAlignParagraphCenter
        '.Footers(wdHeaderFooterPrimary).PageNumbers.Add
    End With
xlBook.Close
xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
WordDoc.SaveAs chemin
WordApp.ActiveDocument.Close
Set WordApp = Nothing
If Rep = "" Then Exit Sub
 t = Timer + 1: Do Until Timer > t: DoEvents: Loop
    Next
End Sub

A+

 

[vgendron]

Re : [non résolu] creation auto. de fichier excel avec repertoire

Bonjour,

Voir PJ..
par contre.. ca m'a l'air d'être assez long quand meme déjà avec 10 produits..
il y a certainement plus efficace et plus rapide.. mais c'est déjà un début
pour changer le répertoire de sortie: il faut modifier une ligne de code
Alt +F11 pour ouvrir l'éditeur VBA
ensuite. lis les commentaires que j'ai mis partout. tu devrais comprendre le fonctionnement de la macro


et dans le fichier excel, j'ai créé des zones nommées dynamiquement
pour les voir: Gestionnaire de noms


Hello Lone Wolf.. plus rapide ;-)

 

[Laosurlamontagne]

Re : [Résolu] creation auto. de fichier excel avec repertoire

@ Lone-wolf: du vin chaud !!

Merci pour vos réponse fort complètes, je ne m'attendais pas à un code aussi... long !

De Lone-wolf: j'ai adapté le répertoire cible et la macro bute sur "Dim WordApp As Word.Application", message: type défini par l'utilisateur non défini"

De Vgendron: la macro fonctionne parfaitement ! Merci !!

A moi de l'adapter à présent !

Merci encore.

 

[Lone-wolf]

Re : [non résolu] creation auto. de fichier excel avec repertoire

Bonjour Laosurlamontagne,

Pas mal de neige, n'est-ce pas ? .


Si tu peux redescendre en ville (à ski bienentendu ) , voici une proposition.

Public Rep$, Racine$, Nom$, Nm$, produit As Range
Public Compteur%, wb As Workbook, wM

Sub Macro2()

Racine = "D:\Dossier\"
Sheets("Resultat cherché").Activate
   
For Each produit In Range("ListeProduits")
    
    Nom = ActiveSheet.Range("A1")   'Nom du classeur - Produit-1
    Rep = racine
    
    Application.DisplayAlerts = False  'On évite les messages,  trop fastidieux

    'Cette ligne suffit, pas besoin de tout reprendre et ajouter l'extension,  _
    on sauvegarde au format .xlsx avec xlOpenXMLWorkbook
    ActiveWorkbook.SaveAs Filename:= Rep & produit, FileFormat:=xlOpenXMLWorkbook
        
   'On Renomme les nouveaus classeurs  "Produits-" & 1 à 10
    For Each wb In Workbooks
    wb.ActiveSheet.Name = Nom
    wb.ActiveSheet.DrawingObjects.Delete 'Supprime le(s) bouton(s) ou autres shapes
  
'On supprime le(s) module(s),  les fichiers .xlsx ne supportant pas les macros.
For Each wM In wb.VBProject.VBComponents
   If wM.Type = vbext_ct_StdModule Then
        wb.VBProject.VBComponents.Remove wb.VBProject.VBComponents(wM.Name)
   End If
 Next
 
 'On supprime la(les) feuille(s) inutile(s)
 For Compteur = wb.Worksheets.Count To 1 Step -1 ' Compte le nombre de feuilles
        Nm = wb.Sheets(Compteur).Name
        wb.ActiveSheet.Name = Nom
          Select Case Nm
        Case "Base de donnée", wb.ActiveSheet.Name  'On sauvegarde les feuilles à cause des liaisons des cellules.
        Case Else
            wb.Sheets(Compteur).Delete
        End Select
    Next Compteur
    wb.Save
    Next
Next produit
End Sub

Bon Weekend

 

[Laosurlamontagne]

Re : [non résolu] creation auto. de fichier excel avec repertoire

Re-coucou !

Après des jours de trifouillage sur la base de votre aide et d'autre post, je partage ici la solution que j'ai trouvé, en espérant que ça aide ou inspire d'autre personne...

Merci à vous !

Sub macro2()
'
'créé un fichier du nom du produit, et l'enregistre dans le répertoire du meme nom

'mettre le répertoire racine dans lequel tous les répertoires produit1 produit2 seront créés
racine = "C:\Macro\"

'pour chaque produit de la base de données (colonne A)
For Each fifiche In Range("fifiche")





'on met le produit dans la cellule A1 de la feuille résultat
    'ainsi, les data colonne B se mettent à jour avec la formule présente
    Sheets("Extract").Range("C3") = fifiche
    Sheets("Extract").Range("C4") = fifiche.Offset(0, 1).Value 
    Sheets("Extract").Range("C7") = fifiche.Offset(0, 9).Value 
   NomFile = Sheets("Extract").Range("C7") & "_" & Sheets("Extract").Range("C4") & "_" & fifiche



    'on donne le nom du nouveau répertoire: créé à partir de la racine et du nom du produit
    NouveauRepertoire = racine & NomFile
    
    
    'on créé le répertoire
    MkDir NouveauRepertoire
    
    'on se place dedans
    ChDir NouveauRepertoire
    
    'on copie la feuille "Résultat cherché dans un nouveau fichier dont le nom est "Produit"
 '   Sheets("Extract").Select
  
 With ThisWorkbook
 .Sheets(Array("Extract", "truc", "bidule", "machin", "Setup")).Copy
    ActiveWorkbook.SaveAs Filename:= _
    NouveauRepertoire & "\" & NomFile & ".xlsm", FileFormat:= _
    xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
 End With


        
        
    'pour éviter les liaisions entre classeur, on fait un copier collage spécial valeur
   Sheets("Extract").Select
   Range("B2:D50").Select
   Selection.Copy
   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        

        
    'on peut aussi fermer ce fichier nouvellement créé
    'Sheets("Extract").Select
    Sheets("Extract").Name = "feuifeuille"


    
    
    ActiveWorkbook.Save
    ActiveWorkbook.Close


Next fifiche
  
End Sub