Correction d'une macro

Le 15/05/2017 à 02:04

Salut,

Je bute sur un bug dans cette macro qui permet de copier le texte de cellules dans un fichier word à l'endroit de signets. Je ne suis pas le créateur de cette macro mais c'est exactement ce dont j'ai besoin, seul problème j’obtiens le bug: utilisation incorrecte du mots clés .

Private Sub CommandButton1_Click() ' Code du bouton Imprimer du Userform
Dim NDF As String, NDF2 As String, Rep As String
Dim WordApp As Object, WordDoc As Object

    Rep = "C:\Users\maxim\Desktop\"
    NDF = Rep & "audit.doc"

    If Not Exist_Fichier(NDF) Then ' Verifie si le doc existe
       MsgBox "Document word manquant", vbExclamation, "Floflo"
    Else
        On Error Resume Next
        If Fichier_IsOpen(NDF) Then ' Verifie si le doc est déja ouvert
            Set WordApp = GetObject(, "Word.Application")
            Set WordDoc = WordApp.Documents(NDF)
        Else
            Set WordApp = CreateObject("Word.Application")
            Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
        End If

        With WordApp
            .Visible = False

            ' copie le contenu du textbox1 à l'emplacement du signet "ref"
            .Selection.Goto what:=wdGoToBookmark, Name:="ref"
            .Selection.TypeText Text:=Me.TextBox1.Text

            ' copie le contenu des textbox2 et 3 à l'emplacement du signet "NomPrenom"
            .Selection.Goto what:=wdGoToBookmark, Name:="NomPrenom"
            .Selection.TypeText Text:=Me.TextBox2.Text & " " & Me.TextBox3.Text

            ' etc ... à continuer ...

        End With

       ' pour enregistrer le doc avec les divers éléments
        NDF2 = Rep & Me.ComboBox1.Text & Me.TextBox9.Text & Me.TextBox10.Text & ".doc"
        WordDoc.Application.ActiveDocument.SaveAs NDF2

        WordApp.Visible = True ' laisse le doc ouvert
        Set WordDoc = Nothing
        Set WordApp = Nothing
        MsgBox "Document word prêt"

    End If
End Sub

' 2 fonctions pouvant être placées dans un module quelconque (ou dans le le code de l'USF)
Function Exist_Fichier(S As String) As Boolean ' vérifie si un fichier existe
Dim tatiak As Object
    Set tatiak = CreateObject("Scripting.FileSystemObject")
    Exist_Fichier = tatiak.FileExists(S)
End Function

Function Fichier_IsOpen(ByRef Ttk As String) As Boolean ' vérifie si un fichier est déjà ouvert
    On Error Resume Next
    Open Ttk For Input Lock Read As #1
    Close #1
    Fichier_IsOpen = (Err.Number <> 0)
End Function

voila si quelqu'un a une idée, se serait très apprécié merci

Le 15/05/2017 à 07:15

Bonjour,

Sur quelle ligne se produit le bug ? Car sans tes fichiers pas facile à trouver !

Le code utilise une constante Word qu'Excel ne connait pas donc, soit c'est :

Const wdGoToBookmark = -1
.Selection.Goto what:=wdGoToBookmark, Name:="ref"

soit c'est :

.Selection.Goto what:=-1, Name:="ref"
Le 15/05/2017 à 15:21

Salut,

merci de cette reponse rapide, le bug se produit ici:

 .Selection.TypeText Text:=Me.TextBox1.Text

je vous joins les fichier, en esperant que ca aide.

5test.xlsm (20.10 Ko)
3audit.docx (83.41 Ko)
Le 15/05/2017 à 21:00

Re,

Mais tu n'as aucun TextBox sur ta feuille, c'est pour ça que ça plante !

Le 17/05/2017 à 18:33

Bonjour,

désolé mauvais fichier, ça fait plusieurs tentatives et je commence a mis perdre.

Je voudrais que ça copie la colonne A ou certaines cellules (d'ou le range()). Egalement dans la version finale il y aura plusieurs worksheet.

J'ai essayé les modifications proposées par Theze (et merci bien), rien ne s'affiche dans mon word. Il y a surement plusieurs erreurs.

Dans tous les cas merci de vos participations, super forum.

4audit.docx (83.42 Ko)
6test.xlsm (22.58 Ko)
Le 19/05/2017 à 00:07

Si quelqu'un a le temps de jeter un œil se serait vraiment apprécié:

Sub export_to_word()
Dim NDF As String, NDF2 As String, Rep As String
Dim WordApp As Object, WordDoc As Object

    Rep = "C:\Users\maxim\Desktop\"
    NDF = Rep & "audit.docx"

    If Not Exist_Fichier(NDF) Then ' Verifie si le doc existe
      MsgBox "Document word manquant", vbExclamation, "no no no"
    Else
        On Error Resume Next
        If Fichier_IsOpen(NDF) Then ' Verifie si le doc est déja ouvert
           Set WordApp = GetObject(, "Word.Application")
            Set WordDoc = WordApp.Documents(NDF)
        Else
            Set WordApp = CreateObject("Word.Application")
            Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
        End If

        With WordApp
            .Visible = False

            ' copie le contenu du textbox1 à l'emplacement du signet "ref"
            Const wdGoToBookmark = -1
            .Selection.Goto what:=wdGoToBookmark, Name:="ref"
            .Selection.TypeText Text:=Worksheets(Feuil1).Range(A1, A99)

            ' etc ... à continuer ...

        End With

       ' pour enregistrer le doc avec les divers éléments
       NDF2 = Rep & "audit2.docx"
        WordDoc.Application.ActiveDocument.SaveAs NDF2

        WordApp.Visible = True ' laisse le doc ouvert
       Set WordDoc = Nothing
        Set WordApp = Nothing
        MsgBox "Document word prêt"

    End If
End Sub

' 2 fonctions pouvant être placées dans un module quelconque (ou dans le le code de l'USF)
Function Exist_Fichier(S As String) As Boolean ' vérifie si un fichier existe
Dim tatiak As Object
    Set tatiak = CreateObject("Scripting.FileSystemObject")
    Exist_Fichier = tatiak.FileExists(S)
End Function

Function Fichier_IsOpen(ByRef Ttk As String) As Boolean ' vérifie si un fichier est déjà ouvert
   On Error Resume Next
    Open Ttk For Input Lock Read As #1
    Close #1
    Fichier_IsOpen = (Err.Number <> 0)
End Function

merci

Le 19/05/2017 à 07:24

Bonjour,

Voilà le code que j'ai testé sur ton fichier Word et ça fonctionne très bien :

Private Sub CommandButton1_Click() ' Code du bouton Imprimer du Userform

Dim NDF As String, NDF2 As String, Rep As String
Dim WordApp As Object, WordDoc As Object

Const wdGoToBookmark As Integer = -1

    Rep = "C:\Users\Delta-Calor\Downloads\" '"C:\Users\maxim\Desktop\"
    NDF = Rep & "audit.docx"

    If Not Exist_Fichier(NDF) Then ' Verifie si le doc existe
      MsgBox "Document word manquant", vbExclamation, "Floflo"
    Else
        On Error Resume Next
        If Fichier_IsOpen(NDF) Then ' Verifie si le doc est déja ouvert
           Set WordApp = GetObject(, "Word.Application")
            Set WordDoc = WordApp.Documents(NDF)
        Else
            Set WordApp = CreateObject("Word.Application")
            Set WordDoc = WordApp.Documents.Open(NDF, ReadOnly:=False)
        End If

        With WordApp
            .Visible = True 'False

            ' copie le contenu du textbox1 à l'emplacement du signet "ref" (existant !)
            .Selection.Goto what:=wdGoToBookmark, Name:="ref"
            .Selection.TypeText Text:=Worksheets("Feuil1").Range("A1").Value

            .Selection.Goto what:=wdGoToBookmark, Name:="Typedecampagne" ' (créé pour le test !)
            .Selection.TypeText Text:=Worksheets("Feuil1").Range("A2").Value

        End With

       'pour enregistrer le doc avec les divers éléments
'       NDF2 = Rep & Me.ComboBox1.Text & Me.TextBox9.Text & Me.TextBox10.Text & ".doc"
'       WordDoc.Application.ActiveDocument.SaveAs NDF2

        WordApp.Visible = True ' laisse le doc ouvert
        Set WordDoc = Nothing
        Set WordApp = Nothing
        MsgBox "Document word prêt"

    End If

End Sub

Pour les tests, j'ai juste modifié les signets, le signet "ref" je l'ai attribué à un mot afin qu'il soit remplacé par le texte situé en cellule A1 et j'ai créé un second signet (zone) dans le document pour qu'il soit remplacé par le texte situé dans la cellule A2 et tout ceci fonctionne bien !

J'ai ensuite supprimé les mots qui formaient les signet pour les créer à l'emplacement du curseur et là aussi, ça a bien fonctionné !

Rechercher des sujets similaires à "correction macro"