XL 2016 macro pour ouverture fichier word

bredeche

bredeche

XLDnaute Occasionnel
Bonjour a tous
je cherche une macro ou userform qui me permettrais de sélectionné ou choisir entre 3 fichier word afin de pouvoir a la suite exécuté ma macro suivante :
VB: 
Sub deb()
chemin = ThisWorkbook.Path & "\"
'Ouverture de l'application word
Set w = CreateObject("word.application")
'ouverture du fichier type
Set doc = w.documents.Open(chemin & ThisWorkbook.Names("fichier").RefersToRange)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    doc.bookmarks(signets(i)).Range = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
Next
w.Visible = True
End Sub
pouvez vous m'aider
encore merci par avance
 
Trier par date Trier par votes
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Bredeche,
Vous pourriez remplacer le début de votre macro par un appel à la macro ci dessous.
Il ouvre une fenêtre avec la liste des fichiers demandés ( ici Word) et à l'emplacement désiré ( dans Chemin)
Une fois sélectionné, le fichier s'ouvre dans Word.

VB: 
Sub OuvrirFichierWord()
    Dim Fichier As String, Chemin As String
    Chemin = "g:\Users\PC_PAPA\Documents\_SYLVAIN\Technique\Excel\" ' Mettre le chemin désiré
    ChDrive "G"                                                        ' Mettre la lettre du lecteur'
    ChDir Chemin
    Fichier = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
    If Fichier = "Faux" Then Exit Sub
    Dim MonApplication As Object
    Set MonApplication = CreateObject("Shell.Application")
    MonApplication.Open (Fichier)
End Sub
 
Vote positif 0 Vote négatif
bredeche

bredeche

XLDnaute Occasionnel
sylvanu à dit:
Bonjour Bredeche,
Vous pourriez remplacer le début de votre macro par un appel à la macro ci dessous.
Il ouvre une fenêtre avec la liste des fichiers demandés ( ici Word) et à l'emplacement désiré ( dans Chemin)
Une fois sélectionné, le fichier s'ouvre dans Word.

VB: 
Sub OuvrirFichierWord()
    Dim Fichier As String, Chemin As String
    Chemin = "g:\Users\PC_PAPA\Documents\_SYLVAIN\Technique\Excel\" ' Mettre le chemin désiré
    ChDrive "G"                                                        ' Mettre la lettre du lecteur'
    ChDir Chemin
    Fichier = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
    If Fichier = "Faux" Then Exit Sub
    Dim MonApplication As Object
    Set MonApplication = CreateObject("Shell.Application")
    MonApplication.Open (Fichier)
End Sub
Cliquez pour agrandir...

merci de ton aide
le début fonctionne
mais j'ai une erreur sur la ligne en jaune
Sub OuvrirFichierWord()
Dim Fichier As String, Chemin As String
Chemin = "C:\Users\cbredeche\OneDrive - Eiffage\SITES\SIEGE VELIZY\EXCEL\fichier assistantes\ExcelWord" ' Mettre le chemin désiré
ChDrive "C" ' Mettre la lettre du lecteur'
ChDir Chemin
Fichier = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
If Fichier = "Faux" Then Exit Sub
Dim MonApplication As Object
Set MonApplication = CreateObject("Shell.Application")
MonApplication.Open (Fichier)
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
doc.bookmarks(signets(i)).Range = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
Next
w.Visible = True
End Sub

merci de ton aide
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
En fait à la colonne 87 du fichier XL il y a des #N/A;
Si la cellule active pointe sur une de ces lignes il y a une erreur de générée.
Pour éviter ça, je teste la cellule avant de l'exporter. Si erreur je saute.
Ca a l'air de marcher.

( NB : Remplacer formule dans D10 par :
=SIERREUR(INDEX(LISTE!$D$4:$O$45;EQUIV(A10;LISTE!$B$4:$B$45;0);EQUIV(C10;LISTE!$D$3:$O$3;0));"")
C'est plus joli, ça masque les #N/A )

VB: 
Sub deb()
chemin = ThisWorkbook.Path & "\"
'Ouverture de l'application word
Set w = CreateObject("word.application")
'ouverture du fichier type
Set doc = w.documents.Open(chemin & ThisWorkbook.Names("fichier").RefersToRange)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    Nom = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
    If Not IsError(Nom) Then
        doc.bookmarks(signets(i)).Range = Nom
    End If
Next
w.Visible = True
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
bredeche

bredeche

XLDnaute Occasionnel
sylvanu à dit:
En fait à la colonne 87 du fichier XL il y a des #N/A;
Si la cellule active pointe sur une de ces lignes il y a une erreur de générée.
Pour éviter ça, je teste la cellule avant de l'exporter. Si erreur je saute.
Ca a l'air de marcher.

( NB : Remplacer formule dans D10 par :
=SIERREUR(INDEX(LISTE!$D$4:$O$45;EQUIV(A10;LISTE!$B$4:$B$45;0);EQUIV(C10;LISTE!$D$3:$O$3;0));"")
C'est plus joli, ça masque les #N/A )

VB: 
Sub deb()
chemin = ThisWorkbook.Path & "\"
'Ouverture de l'application word
Set w = CreateObject("word.application")
'ouverture du fichier type
Set doc = w.documents.Open(chemin & ThisWorkbook.Names("fichier").RefersToRange)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    Nom = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
    If Not IsError(Nom) Then
        doc.bookmarks(signets(i)).Range = Nom
    End If
Next
w.Visible = True
End Sub
Cliquez pour agrandir...


merci mais j'ai une erreur en rouge dans le code ci dessous lorsque je combine les deux macro avec la sélection d'ouvrir un fichier word
car je vais avoir 3 trames différente mais avec les mêmes signets

merci de ton aide

VB: 
Sub OuvrirFichierWord()
Dim Fichier As String, Chemin As String
Chemin = "C:\Users\cbredeche\OneDrive - Eiffage\SITES\SIEGE VELIZY\EXCEL\fichier assistantes\ExcelWord" ' Mettre le chemin désiré
ChDrive "C" ' Mettre la lettre du lecteur'
ChDir Chemin
Fichier = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
If Fichier = "Faux" Then Exit Sub
Dim MonApplication As Object
Set MonApplication = CreateObject("Shell.Application")
MonApplication.Open (Fichier)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    Nom = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
    If Not IsError(Nom) Then
        [COLOR=rgb(184, 49, 47)]doc.bookmarks(signets(i)).Range = Nom[/COLOR]
    End If
Next
w.Visible = True
End Sub
 

Pièces jointes

  • ES MAI-48-DO-SUIVI CONTRAT SST-2019-11-V1 .xlsm
    391.8 KB · Affichages: 6
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Je ne vois pas la ligne en rouge ci dessus. Quelle ligne est en erreur ?

Il y a une erreur, vous aviez :
VB: 
chemin = ThisWorkbook.Path & "\"
Donc il faut rajouter le \ à la fin du chemin dans le second module :
Code: 
Chemin = "C:\Users\cbredeche\OneDrive - Eiffage\SITES\SIEGE VELIZY\EXCEL\fichier assistantes\ExcelWord\"
Le \ signifie qu'il doit aller en dessous de la dernière directory, et non au même niveau.
 
Vote positif 0 Vote négatif
bredeche

bredeche

XLDnaute Occasionnel
sylvanu à dit:
Je ne vois pas la ligne en rouge ci dessus. Quelle ligne est en erreur ?

Il y a une erreur, vous aviez :
VB: 
chemin = ThisWorkbook.Path & "\"
Donc il faut rajouter le \ à la fin du chemin dans le second module :
Code: 
Chemin = "C:\Users\cbredeche\OneDrive - Eiffage\SITES\SIEGE VELIZY\EXCEL\fichier assistantes\ExcelWord\"
Le \ signifie qu'il doit aller en dessous de la dernière directory, et non au même niveau.
Cliquez pour agrandir...

désolé le code bloque a ce niveau

doc.bookmarks(signets(i)).Range = Nom
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Le problème vient du fait que doc n'est plus défini.
Avec ça, ça a l'air de marcher :
VB: 
Sub deb2()
    Dim Fichier As String, Chemin As String
    Chemin = "g:\Users\PC_PAPA\Documents\_SYLVAIN\Technique\Excel\" ' Mettre le chemin désiré
    ChDrive "G"                                                        ' Mettre la lettre du lecteur'
    ChDir Chemin
    Fichier = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
    If Fichier = "Faux" Then Exit Sub
    Dim MonApplication As Object
    Set MonApplication = CreateObject("Shell.Application")
    MonApplication.Open (Fichier)
'ouverture du fichier type
    NbDoc = Split(Fichier, "\")
    Set w = CreateObject("word.application")
    Set doc = w.documents.Open(Fichier)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    Nom = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
    If Not IsError(Nom) Then
        doc.bookmarks(signets(i)).Range = Nom
    End If
Next
w.Visible = True
End Sub
 
Vote positif 0 Vote négatif
bredeche

bredeche

XLDnaute Occasionnel
sylvanu à dit:
Le problème vient du fait que doc n'est plus défini.
Avec ça, ça a l'air de marcher :
VB: 
Sub deb2()
    Dim Fichier As String, Chemin As String
    Chemin = "g:\Users\PC_PAPA\Documents\_SYLVAIN\Technique\Excel\" ' Mettre le chemin désiré
    ChDrive "G"                                                        ' Mettre la lettre du lecteur'
    ChDir Chemin
    Fichier = Application.GetOpenFilename("Word Files (*.doc*), *.doc*")
    If Fichier = "Faux" Then Exit Sub
    Dim MonApplication As Object
    Set MonApplication = CreateObject("Shell.Application")
    MonApplication.Open (Fichier)
'ouverture du fichier type
    NbDoc = Split(Fichier, "\")
    Set w = CreateObject("word.application")
    Set doc = w.documents.Open(Fichier)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    Nom = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
    If Not IsError(Nom) Then
        doc.bookmarks(signets(i)).Range = Nom
    End If
Next
w.Visible = True
End Sub
Cliquez pour agrandir...
merci mais j'ai un problème un message de word s'affiche en disant que le fichier .doc est deja ouvert et il me donne 3 choix
j'ai réaliser les 3 essais aucun signet ne s'affiche

en suite le doc n 'est pas nommé mais sur mes derniers post j explique que j'ai le choix entre 3 trames différentes donc le fichier nomme dans l'excel qui ce trouve dans l'onglet acceuil ne serait plus utilisable
encore merci m'aider sur le sujet
 
Dernière édition:
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Chez moi, ça à l'air de fonctionner. Il me demande effectivement mais je réponds ok.

Mais si votre première macro fonctionnait bien, pourquoi pas simplement la dupliquer si vous n'avez que 3 fichiers :
VB: 
Sub deb()

' Fichier1
chemin = ThisWorkbook.Path & "\"
'Ouverture de l'application word
Set w = CreateObject("word.application")
'ouverture du fichier type
Set doc = w.documents.Open(chemin & ThisWorkbook.Names("fichier1").RefersToRange)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    Nom = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
    If Not IsError(Nom) Then
        doc.bookmarks(signets(i)).Range = Nom
    End If
Next
w.Visible = True

' Fichier2
chemin = ThisWorkbook.Path & "\"
'Ouverture de l'application word
Set w = CreateObject("word.application")
'ouverture du fichier type
Set doc = w.documents.Open(chemin & ThisWorkbook.Names("fichier2").RefersToRange)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    Nom = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
    If Not IsError(Nom) Then
        doc.bookmarks(signets(i)).Range = Nom
    End If
Next
w.Visible = True

' Fichier3
chemin = ThisWorkbook.Path & "\"
'Ouverture de l'application word
Set w = CreateObject("word.application")
'ouverture du fichier type
Set doc = w.documents.Open(chemin & ThisWorkbook.Names("fichier3").RefersToRange)
'numéro des colonnes comprenant les données
champs = Array(76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90)
'tableau des signets du fichier type
signets = Array("NCONTRAT", "Entreprise", "AdresseENTREPRISE", "CODEPOSTAL", "NOMPRENOM", "INTITULECONTRAT", "CADRECONTRACTUEL", "SITESEXECUTIONS", "PRIX", "PRIXENLETTRE", "PAIEMENTS", "CODEIMPUTATION", "ANNEXE", "DATE", "NCONTRAT2")
'écriture des signets
For i = LBound(signets) To UBound(signets)
    Nom = Sheets("TABLEAU CONTRAT SOUS-TRAITANCE").Cells(ActiveCell.Row, champs(i))
    If Not IsError(Nom) Then
        doc.bookmarks(signets(i)).Range = Nom
    End If
Next
w.Visible = True

End Sub
Et si ça, ça marche chez vous correctement, et s'il y a plus de fichiers, on pourra améliorer.
 
Vote positif 0 Vote négatif

Discussions similaires

bredeche
  • Question
XL 2016 Tableau excel remplisage trame word amelioration
Réponses
1
Affichages
873
bredeche
bredeche
bredeche
  • Question
XL 2016 excel word
Réponses
1
Affichages
766
sylvanu
sylvanu
C
  • Question
Word Macro sur Word
Réponses
2
Affichages
2 K
CaEly
C
F
  • Question
Macro Excel VBA vers Word - Mise en forme des signets
Réponses
6
Affichages
9 K
Numidia
N

Membres actuellement en ligne

2 membres et 56 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 097
Messages
2 116 186
Membres
112 679
dernier inscrit
Yupanki