Microsoft 365 Remplir un tableur Excel a partir d'un document Word

Azuveus

XLDnaute Nouveau
Bonsoir à tous,

Je souhaiterais savoir si il est possible de remplir un tableau excel a partir d'un document word.
Je m'explique, j'ai un document word qui contient un bouton macro VBA et je souhaiterais que lorsque je clique sur ce bouton, il ouvre un fichier Excel, qu'il se positionne dans une case d'un onglet bien defini qu'il remplisse la case et qu'il le sauvegarde.

Voici mon code:
VB:
Private Sub CommandButton2_Click()

'Declaration des variables
Dim TitreMail As String
Dim NomFichier As String
Dim NomClient As String
Dim NumFacture As String
Dim TypeDoc As String
Dim Reason As String
Dim Lien As String
Dim Week As String
Dim Month As String
Dim MailFor As String

'Variable pour remplisage du fichier Excel annexe.
Dim Excelapp As Excel.Application
Dim Excelsheet As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim rgFound As Range
Dim X As Integer

'Récupération des variables
TypeDoc = Left(ActiveDocument.Tables(1).Cell(1, 2).Range.Text, Len(ActiveDocument.Tables(1).Cell(1, 2).Range.Text) - 1)
NomClient = Left(ActiveDocument.Tables(1).Cell(2, 2).Range.Text, Len(ActiveDocument.Tables(1).Cell(2, 2).Range.Text) - 1)
NumFacture = Left(ActiveDocument.Tables(1).Cell(6, 2).Range.Text, Len(ActiveDocument.Tables(1).Cell(6, 2).Range.Text) - 1)
Reason = ActiveDocument.Tables(1).Cell(9, 2).Range.Text
Lien = "\\....\DEMANDE_2021"
NomFichier = Left(TypeDoc, Len(TypeDoc) - 1) & " - " & Left(NomClient, Len(NomClient) - 1) & " - " & Left(NumFacture, Len(NumFacture) - 1)
TitreMail = "REQUEST FOR CREDIT - " & NomClient & " - " & TypeDoc & " - FA " & NumFacture

Week = Left(ActiveDocument.Tables(2).Cell(2, 1).Range.Text, Len(ActiveDocument.Tables(2).Cell(2, 1).Range.Text) - 1)
Month = Left(ActiveDocument.Tables(2).Cell(2, 2).Range.Text, Len(ActiveDocument.Tables(2).Cell(2, 2).Range.Text) - 1)
MailFor = Left(ActiveDocument.Tables(2).Cell(2, 3).Range.Text, Len(ActiveDocument.Tables(2).Cell(2, 3).Range.Text) - 1)

' Blocage du bouton si le mail n'est pas renseigné.
If MailFor <> "Choose an item." Then

    'Initialisation du doc Excel
    Set Excelapp = CreateObject("Excel.application")
    Excelapp.Visible = False
    Set Exceldoc = Excelapp.Documents.Open("\\....\DOA.xlsx")
  
   
    'Remplissage du document Excel
    
    Set xlSheet = xlBook.Sheets(Month) 'ici feuille du classeur
    
    Set rgFound = xlSheet.Range("C15:C100").Find(Week)
    xlSheet.Range("A" & rgFound.Row + 1).Select
    xlSheet.Selection.EntireRow.Insert
    X = xlSheet.ActiveCell.Row
    
    xlSheet.Range("B" & X) = TypeDoc
      
    'Sauvegarde du tableau excel.
    Excelapp.Workbooks.Save
        
 
    'Sauvegarde une copie du fichier sur le Groupe G
            ActiveDocument.ExportAsFixedFormat OutputFileName:= _
            "\\....\" & NomFichier & ".pdf", ExportFormat:= _
            17, OpenAfterExport:=False, OptimizeFor:= _
            0, Range:=0, From:=1, To:=1, _
            Item:=0, IncludeDocProps:=True, KeepIRM:=True, _
            CreateBookmarks:=0, DocStructureTags:=True, _
            BitmapMissingFonts:=True, UseISO19005_1:=False


    Dim ol As Object, monItem As Object
    Set ol = CreateObject("outlook.application")
    Set monItem = ol.CreateItem(olMailItem)

    monItem.To = MailFor
    monItem.CC = "mail@xxx.com"

    monItem.Subject = TitreMail
    monItem.HTMLBody = "Bonjour,<br /><br /> Veuillez trouver ci-joint la demande valide pour une <b>" & TypeDoc & "</b><br /> Client : <b>" & _
    NomClient & "</b><br /> Numero de facture : <b>" & NumFacture & "</b><br />Raison : <b>" & Reason & "</b></b><br /><br />Une copie de ce fichier est enregistre sur le groupe G. <br /> Dossier de sauvegarde : " & _
    Lien & "<br /><br />Pensez a mettre ce document en Piece jointe sur S.A.P.<br /><br /> Cordialement.<br /><br />Guillaume <br />."

    monItem.Attachments.Add ("\\....\" & NomFichier & ".pdf")
    monItem.Send

    Set ol = Nothing
Else

    Set ol = Nothing
    MsgBox "Veuillez indiquer le destinataire du mail.", vbExclamation

End If

End Sub

Lorsque j'execute ce code, voila l'erreure :
1632850134631.png


Que dois-je faire ?

Merci d'avance,
Azuveus.
 
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
314 628
Messages
2 111 337
Membres
111 104
dernier inscrit
JEMADA