XL 2016 macro pour ouverture fichier word

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
 

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
 

bredeche

XLDnaute Occasionnel
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

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
 

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:

bredeche

XLDnaute Occasionnel
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


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

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.
 

bredeche

XLDnaute Occasionnel
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.

désolé le code bloque a ce niveau

doc.bookmarks(signets(i)).Range = Nom
 

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
 

bredeche

XLDnaute Occasionnel
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
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:

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.
 

Statistiques des forums

Discussions
311 730
Messages
2 081 978
Membres
101 854
dernier inscrit
micmag26