Transformation macro Excel en macro word

Le 14/08/2015 à 10:59

Bonjour à toute l'équipe,

je voudrais avoir une macro que je lance a partir d'un classeur excel pour ouvrir un fichier word et ensuite creer un dossier(qui sera nommé grace au contenu des cellules A1 et A2) et enregistrer le fichier word (renomé lui aussi avec les cellules A1 et A2)dans ce dossier

je vous remercie tous pour votre aide precieuse

Le 15/08/2015 à 10:40

Bonjour,

Teste le code qui suit. Je suis partis du postulat que le nom du dossier est en A1 et le nom du fichier (sans extension .doc) est en A2, le dossier parent étant le dossier où se trouve le classeur :

Sub DossierWord()

    Dim AppWord As Object
    Dim Doc As Object
    Dim Chemin As String
    Dim Dossier As String
    Dim Fichier As String

    'nom du dossier en A1
    Dossier = ActiveSheet.Range("A1").Value

    'vérifie que l'anti slash est présent en fin de texte
    If InStrRev(Dossier, "\") = 0 Then Dossier = Dossier & "\"

    'nom du fichier en A2
    Fichier = ActiveSheet.Range("A2").Value

    'le dossier parent est le dossier du classeur
    Chemin = ThisWorkbook.Path & "\" & Dossier

    On Error Resume Next 'au cas où le dossier existe déjà
    'création du dossier
    MkDir Chemin

    'supprime le gestionnaire
    On Error GoTo 0

    'création de l'application Word
    Set AppWord = CreateObject("Word.Application")

    With AppWord

        .Visible = True 'rendue visible

        Set Doc = .Documents.Add 'ajoute un document
        Doc.SaveAs Chemin & Fichier   'et l'enregistre

    End With

End Sub

Hervé.

Le 15/08/2015 à 18:31

Bonjour,

je te remercie vivement pour ton aide si precieuse.

A premiere vue cela fonctionne tres bien: creation du dossier et sauvegarde du fichier.

Maintenant i l me reste a l'adapter à tout le travail et je te tiendrai au courant en esperant ne pas avoir de probleme.

je te remercie encore une fois.

A+

Le 15/08/2015 à 18:50

Re-bonsoir,(Theze et/ou Hervé)

une premiere contrainte:

J'ai mes fichiers word types stockés dans un dossier ("Dossier_fichiers").

Serait-il possible d'avoir une liste box avec le nom des fichiers stockés dans ce dossier et ensuite choisir le fichier word à ouvrir.

ensuite creation du dossier nommé en A1 (ce qui est deja bon) et enregistrement sous (nom en A2) du fichier word ouvert.

Cordialement

Le 16/08/2015 à 09:53

Bonjour,

En tout premier, tu doit poser sur ta feuille une ListBox de type "Formulaire" que tu nomme "Zone de liste 1" si ce n'est pas le nom par défaut (voir la zone de nom à gauche de la barre de formule). Une fois ceci fait, tu exécute la proc "RemplirListeBox" en ayant au préalable adapter le chemin (ici, --> Chemin = ThisWorkbook.Path & "\Dossier_fichiers\") et l'extension (.doc,.docx,etc...). Quand la ListBox est remplie(La fonction "Fichiers" est appelée et elle retourne un tableau), un clic sur un élément de la liste va déclencher la proc "Ouvrir" avec en argument le chemin du dossier où se trouvent les fichiers listés puis, création du dossier, création de l'application Word, ouverture du fichier choisi et enregistrement sous...

Sub RemplirListeBox()

    Dim S As Shape
    Dim Tbl() As String
    Dim I As Integer
    Dim Chemin As String
    Dim Ext As String

    'adapter le nom de la ListBox dans la zone de nom d'Excel
    'à gauche de la barre de formule (définir le nom puis appui sur "Entrée")
    Set S = ActiveSheet.Shapes("Zone de liste 1")

    'adapter le chemin
    Chemin = ThisWorkbook.Path & "\Dossier_fichiers\"

    'extension du type de fichiers
    Ext = ".doc"

    'définie la procédure appelée par la ListBox sur clic d'un élément
    'en appelant la proc Ouvrir par la ListBox, on est sûr qu'un choix a été fait !
    'le dossier pour l'ouverture du fichier est passé en argument
    S.OnAction = "'Ouvrir """ & Chemin & "'"

    'supprime les éléments de la liste avant remplissage
    S.ControlFormat.RemoveAllItems

    'récupère la liste des fichiers du dossier
    Tbl() = Fichiers(Chemin, Ext)

    'et les entre dans la ListBox
    For I = 1 To UBound(Tbl)

        S.ControlFormat.AddItem Tbl(I)

    Next I

End Sub

Function Fichiers(Chemin As String, _
                  Extension As String) As String() 'la fonction retourne un tableau

    Dim Tbl() As String
    Dim Fich As String
    Dim I As Integer

    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    'seuls les fichiers avec l'extension voulue
    Fich = Dir(Chemin & "*" & Extension)

    Do While (Len(Fich) > 0)

        I = I + 1
        ReDim Preserve Tbl(1 To I)
        Tbl(I) = Fich

        Fich = Dir()

    Loop

    Fichiers = Tbl()

End Function

Sub Ouvrir(CheminFichier As String)

    Dim AppWord As Object
    Dim Doc As Object
    Dim Chemin As String
    Dim Dossier As String
    Dim Fichier As String

    'nom du dossier en A1
    Dossier = ActiveSheet.Range("A1").Value

    'vérifie que l'anti slash est présent en fin de texte
    If Right(Dossier, 1) <> "\" Then Dossier = Dossier & "\"

    'nom du fichier en A2
    Fichier = ActiveSheet.Range("A2").Value

    'le dossier parent est le dossier du classeur
    Chemin = ThisWorkbook.Path & "\" & Dossier

    On Error Resume Next 'au cas où le dossier existe déjà
   'création du dossier
    MkDir Chemin

    'supprime le gestionnaire
    On Error GoTo 0

    'création de l'application Word
    Set AppWord = CreateObject("Word.Application")

    AppWord.Visible = True 'rendue visible

    'ouvre le document
    With ActiveSheet.Shapes("Zone de liste 1").ControlFormat

        Set Doc = AppWord.Documents.Open(CheminFichier & .List(.ListIndex))

    End With

    Doc.SaveAs Chemin & Fichier 'et l'enregistre sous...

End Sub

Hervé.

Le 16/08/2015 à 12:23

Bonjour Hervé,

Un grand merci pour ton travail.

j'ai le code d'erreur 1004: "Erreur definie par lapplication ou par l'objet"

au niveau de la ligne de code:

   S.OnAction = "'Ouvrir """ & Chemin & "'"

je n'arrive pas a la resoudre.

Cordialement

A+

Le 17/08/2015 à 07:07

Bonjour,

OnAction et le passage d'arguments pose souvent problème

Teste de cette façon, la variable est déclarée en tête de module de cette façon, il ne devrait pas y avoir de problème :

Dim CheminFichier As String

Sub RemplirListeBox()

    Dim S As Shape
    Dim Tbl() As String
    Dim I As Integer
    Dim Ext As String

    'adapter le nom de la ListBox dans la zone de nom d'Excel
   'à gauche de la barre de formule (définir le nom puis appui sur "Entrée")
   Set S = ActiveSheet.Shapes("Zone de liste 1")

    'adapter le chemin
   CheminFichier = ThisWorkbook.Path & "\Dossier_fichiers\"

    'extension du type de fichiers
   Ext = ".doc"

    'définie la procédure appelée par la ListBox sur clic d'un élément
   'en appelant la proc Ouvrir par la ListBox, on est sûr qu'un choix a été fait !
   'le dossier pour l'ouverture du fichier est passé en argument
   S.OnAction = "Ouvrir"

    'supprime les éléments de la liste avant remplissage
   S.ControlFormat.RemoveAllItems

    'récupère la liste des fichiers du dossier
   Tbl() = Fichiers(CheminFichier, Ext)

    'et les entre dans la ListBox
   For I = 1 To UBound(Tbl)

        S.ControlFormat.AddItem Tbl(I)

    Next I

End Sub

Function Fichiers(Chemin As String, _
                  Extension As String) As String() 'la fonction retourne un tableau

    Dim Tbl() As String
    Dim Fich As String
    Dim I As Integer

    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    'seuls les fichiers avec l'extension voulue
   Fich = Dir(Chemin & "*" & Extension)

    Do While (Len(Fich) > 0)

        I = I + 1
        ReDim Preserve Tbl(1 To I)
        Tbl(I) = Fich

        Fich = Dir()

    Loop

    Fichiers = Tbl()

End Function

Sub Ouvrir()

    Dim AppWord As Object
    Dim Doc As Object
    Dim Chemin As String
    Dim Dossier As String
    Dim Fichier As String

    'nom du dossier en A1
   Dossier = ActiveSheet.Range("A1").Value

    'vérifie que l'anti slash est présent en fin de texte
   If Right(Dossier, 1) <> "\" Then Dossier = Dossier & "\"

    'nom du fichier en A2
   Fichier = ActiveSheet.Range("A2").Value

    'le dossier parent est le dossier du classeur
   Chemin = ThisWorkbook.Path & "\" & Dossier

    On Error Resume Next 'au cas où le dossier existe déjà
  'création du dossier
   MkDir Chemin

    'supprime le gestionnaire
   On Error GoTo 0

    'création de l'application Word
   Set AppWord = CreateObject("Word.Application")

    AppWord.Visible = True 'rendue visible

    'ouvre le document
   With ActiveSheet.Shapes("Zone de liste 1").ControlFormat

        Set Doc = AppWord.Documents.Open(CheminFichier & .List(.ListIndex))

    End With

    Doc.SaveAs Chemin & Fichier 'et l'enregistre sous...

End Sub

Hervé.

Le 17/08/2015 à 08:48

Bonjour,

merci pour ta reponse.

malheureusment le meme probleme persiste

erruer 1004; erreur definie par l'application ou l'objet