Transformer une liste excel en dossiers windows

[sofysofe]

Transformer une liste excel en dossiers windows

Bonjour,

J'ai une liste d'une colonne contenant des noms, et j'aimerai pouvoir créer automatiquement un dossier par nom (l'emplacement à peu d'importance, C:\Temp par exemple).
Mon fichier d'exemple ne contient que quelques noms, celui sur lequel j'aimerai le faire en contient environ 1200.

Merci d'avance pour votre aide !!!

Sofysofe

 

[Lone-wolf]

Re : Transformer une liste excel en dossiers windows (URGENT ...)

Bonsoir à tous,

Désolé, c'est peut-être un peu tard, mais tampis.

La même macro, mais modifiée, qui crée le dossier principal, le dossier de la personne et un sous-dossier.

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 Sub CreationDossier(sNomRep As String)
'issu d'un code de KiKi29 de http://www.excel-downloads.com/forum/110203-cr-er-dossier-enregistrer-dedans.html
    'ChDrive "D"
    SHCreateDirectoryEx 0&, sNomRep, 0&
End Sub

Sub Tst()
'issu d'un code de KiKi29 de http://www.excel-downloads.com/forum/110203-cr-er-dossier-enregistrer-dedans.html
Dim Rep As String, nomdeb As String, cel As Range, derl&, dos$
derl = Range("A65536").End(xlUp).Rows.Row
nomdeb = "C:\Dossiers Clients\"
For Each cel In Range("A2:A" & derl)
cel.Select
    Rep = ActiveCell.Value
    MsgBox Rep
    CreationDossier nomdeb & Rep & "\Nouveau Dossier"
    Next
End Sub

EDIT: vous pouvez même rajouter un sous-sous-dossier comme ceci:

CreationDossier nomdeb & Rep & "\Nouveau Dossier" & "\Dossier annulé"


A+ 😎

 

[Lone-wolf]

Re : Transformer une liste excel en dossiers windows (URGENT ...)

Bonjour le Forum,

Voici une nouvelle version de la macro avec ajout d'un fichier Word personnalisé.

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
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
Dim WordDoc As Word.Document
derl = Range("A65536").End(xlUp).Row
nomdeb = "D:\Patients\"

On Error Resume Next
For i = 2 To derl
 'Noms des patients
Application.GoTo Range("A" & i)    
    Rep = ActiveCell.Value
    CreationDossier nomdeb & Rep & "\"
   'Nom du fichier  Facturation .doc
    chemin = nomdeb & Rep & "\" & Range("B1").Value & ".doc"   
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False
    Set WordDoc = WordApp.Documents.Add
    With WordApp.Selection
     ' Facture n°:  FC-0156-
    .Text = 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
    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+ 😎