VBA - Transferer des valeurs de Word vers Excel [Résolu]

Messages postés
29
Date d'inscription
samedi 30 juin 2007
Statut
Membre
Dernière intervention
2 janvier 2008
- - Dernière réponse : didieraucun
Messages postés
29
Date d'inscription
samedi 30 juin 2007
Statut
Membre
Dernière intervention
2 janvier 2008
- 10 juil. 2007 à 22:21
Bonsoir à tous, 
A partir d'un
document Word, je souhaites récupérer certaines valeurs d'un tableau
pour les transférer automatiquement dans un fichier Excel.

Avec de l'aide sur des forums, j'ai ce code :
<hr size="2" width="100%" />Sub Test()
Dim objTable As Table
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim a As String
Dim b As String
Dim c As String
 
' Partie 1 : Récupérer les valeurs du tableau Word sans les 2 derniers caractères bizarres
Set objTable = ActiveDocument.Tables(1)

a1 = Len(Mid(objTable.Cell(1, 1), 7, 25)) - 2
a2 = Mid(objTable.Cell(1, 1), 7, a1)

b1 = Len(Mid(objTable.Cell(1, 2), 10, 25)) - 2
b2 = Mid(objTable.Cell(1, 2), 10, b1)

c1 = Len(Mid(objTable.Cell(1, 3), 7, 25)) - 2
c2 = Mid(objTable.Cell(1, 3), 7, c1)

'Partie 2 : Ouverture du fichier excel
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Open("D:\Mes Documents\Excel\ToTo.xls")
Set xlSheet = xlBook.Sheets("Feuil1")
 
'Partie 3 : coller les valeurs dans les cellules de Excel
    xlSheet.Cells(1, 1) = a2
    xlSheet.Cells(1, 2) = b2
    xlSheet.Cells(1, 3) = c2
    
xlApp.Visible = True
End Sub
<hr size="2" width="100%" />
Partie 1 ; pas de problème, je récupère bien mes valeurs 

J'ai des problèmes pour modifier la partie 2 et 3 :

Partie 2
; lorsque j'exécute la macro alors que mon fichier Toto.xls est déjà
ouvert, un nouveau fichier Toto.xls s'ouvre en lecture seule.
Je souhaiterais que si mon fichier est déja ouvert, il active celui-ci.

Partie 3 ; les valeurs sont copiées dans les 3 premières cellules de Excel.
Je
souhaiterais avoir la possibilité de choisir l'emplacement où seront
copiés les valeurs, via un message du type "sélectionner la cellule de
destination"

Pourriez vous m'aider à modifier ce code pour ces deux problèmes 
Afficher la suite 

8 réponses

Meilleure réponse
Messages postés
1855
Date d'inscription
jeudi 23 mai 2002
Statut
Membre
Dernière intervention
24 juin 2018
23
3
Merci
 Bonsoir

l'exemple ci-dessous pourrait, en partie, résoudre le point 2.
Const ForReading 1, ForWriting 2, ForAppending = 8Const TristateUseDefault -2, TristateTrue -1, TristateFalse = 0

Dim strExcelFile, objFso, objFile
strExcelFile = "d:\nouv_barre.xls"
Set objFso = CreateObject("Scripting.FileSystemObject")

On Error Resume Next   
Set objFile = objFso.OpenTextFile(strExcelFile, ForAppending, TristateFalse)

If Err.Number <> 0 Then
   Msgbox "Le fichier est déjà ouvert"&vbCrLf& Err.Number &vbCrLf& _
           Err.Source &vbCrLf& Err.Description : Err.Clear
 Else
   MsgBox "Le fichier n'est pas ouvert"
   Dim objExcel, objClasseur
   objFile.Close
   Set objExcel = CreateObject("Excel.Application")
   Set objClasseur = objExcel.WorkBooks.Open(strExcelFile)
   objExcel.DisplayAlerts = False
   objExcel.Application.Visible=True 'False
   MsgBox "fichier " & strExcelFile & " ouvert"
   objExcel.Quit
   Set objExcel = Nothing
   Set objClasseur = Nothing
End If
Set objFile = Nothing
Set objFso = Nothing

jean-marc

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 141 internautes nous ont dit merci ce mois-ci

Commenter la réponse de cs_JMO
Messages postés
1855
Date d'inscription
jeudi 23 mai 2002
Statut
Membre
Dernière intervention
24 juin 2018
23
3
Merci
Bonsoir,

Après re-test du script et sans lunettes, le message d'erreur est normal !
Que vient faire le "_" dans    If Err.Number <> 0 Then _

jean-marc

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 141 internautes nous ont dit merci ce mois-ci

Commenter la réponse de cs_JMO
Messages postés
29
Date d'inscription
samedi 30 juin 2007
Statut
Membre
Dernière intervention
2 janvier 2008
3
Merci
Fin du post


<hr size="2" width="100%" />
La suite ici

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 141 internautes nous ont dit merci ce mois-ci

Commenter la réponse de didieraucun
Messages postés
29
Date d'inscription
samedi 30 juin 2007
Statut
Membre
Dernière intervention
2 janvier 2008
0
Merci
Merci ... j'ai une erreur de compilation
Commenter la réponse de didieraucun
Messages postés
29
Date d'inscription
samedi 30 juin 2007
Statut
Membre
Dernière intervention
2 janvier 2008
0
Merci
Oui effectivement j'ai fait une erreur en rajoutant ce _
Ce code marche bien
Grand merci à toi jean-marc.

J'ai donc integré ton code dans le mien.
Mais il ne colle plus les valeurs dans le fichier excel ?
Il devrait pourtant terminer la partie 3 !
<hr size="2" width="100%" />Sub Test()
Dim objTable As Table
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim a As String
Dim b As String
Dim c As String
 
' Partie 1 : Récupérer les valeurs du tableau Word sans les 2 derniers caractères bizarres
Set objTable = ActiveDocument.Tables(1)

a1 = Len(Mid(objTable.Cell(1, 1), 7, 25)) - 2
a2 = Mid(objTable.Cell(1, 1), 7, a1)

b1 = Len(Mid(objTable.Cell(1, 2), 10, 25)) - 2
b2 = Mid(objTable.Cell(1, 2), 10, b1)

c1 = Len(Mid(objTable.Cell(1, 3), 7, 25)) - 2
c2 = Mid(objTable.Cell(1, 3), 7, c1)

'Partie 2 : Ouverture du fichier excelConst ForReading 1, ForWriting 2, ForAppending = 8Const TristateUseDefault -2, TristateTrue -1, TristateFalse = 0

Dim strExcelFile, objFso, objFile
strExcelFile = "D:\Mes Documents\Excel\Toto.xls"
Set objFso = CreateObject("Scripting.FileSystemObject")

On Error Resume Next
Set objFile = objFso.OpenTextFile(strExcelFile, ForAppending, TristateFalse)

If Err.Number <> 0 Then
MsgBox "Le fichier est déjà ouvert" & vbCrLf & Err.Number & vbCrLf _
           & Err.Source & vbCrLf & Err.Description: Err.Clear
 Else
   MsgBox "Le fichier n'est pas ouvert"
   Dim objExcel, objClasseur
   objFile.Close
   Set objExcel = CreateObject("Excel.Application")
   Set objClasseur = objExcel.Workbooks.Open(strExcelFile)
   objExcel.DisplayAlerts = False
   objExcel.Application.Visible = True 'False
   MsgBox "fichier " & strExcelFile & " ouvert"
   'objExcel.Quit
   Set objExcel = Nothing
   Set objClasseur = Nothing
  
End If
Set objFile = Nothing
Set objFso = Nothing
 
'Partie 3 : coller les valeurs dans les cellules de Excel
    xlSheet.Cells(1, 1) = a2
    xlSheet.Cells(1, 2) = b2
    xlSheet.Cells(1, 3) = c2
    
xlApp.Visible = True
End Sub
<hr size="2" width="100%" />
Commenter la réponse de didieraucun
Messages postés
1855
Date d'inscription
jeudi 23 mai 2002
Statut
Membre
Dernière intervention
24 juin 2018
23
0
Merci
 Bonjour

   MsgBox "Le fichier n'est pas ouvert"
   Dim objExcel, objClasseur
   objFile.Close
   Set objExcel = CreateObject("Excel.Application")
   Set objClasseur = objExcel.Workbooks.Open(strExcelFile)
   objExcel.DisplayAlerts = False
   objExcel.Application.Visible = True 'False
   MsgBox "fichier " & strExcelFile & " ouvert"

'Partie 3 : coller les valeurs dans les cellules de Excel
ici faire copy de table word dans cellules excel
faire attention si plusieurs onglets dans excel

+ sauvegarde excel

   objExcel.DisplayAlerts = True

   objExcel.Application.Visible = True 'False
   objExcel.Quit
   Set objExcel = Nothing
   Set objClasseur = Nothing

jean-marc
Commenter la réponse de cs_JMO
Messages postés
29
Date d'inscription
samedi 30 juin 2007
Statut
Membre
Dernière intervention
2 janvier 2008
0
Merci
En défintive, le plus simple serait de demarrer une macro directement dans excel notamment pour régler mon problémé de la partie 3 :
Coller les valeurs où je le souhaite.

j'ai donc modifié le code comme suit :
<hr size="2" width="100%" />Sub Test()
Dim objTable As Table
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim a As String
Dim b As String
Dim c As String
'
' Partie 1 : Récupérer les valeurs du tableau Word sans les 2 derniers caractères bizarres
Set objTable = ActiveDocument.Tables(1)
'
a1 = Len(Mid(objTable.Cell(1, 1), 7, 25)) - 2
a2 = Mid(objTable.Cell(1, 1), 7, a1)
'
b1 = Len(Mid(objTable.Cell(1, 2), 10, 25)) - 2
b2 = Mid(objTable.Cell(1, 2), 10, b1)
'
c1 = Len(Mid(objTable.Cell(1, 3), 7, 25)) - 2
c2 = Mid(objTable.Cell(1, 3), 7, c1)
'
'
'Partie 2 : Création excelConst ForReading 1, ForWriting 2, ForAppending = 8Const TristateUseDefault -2, TristateTrue -1, TristateFalse = 0

Dim strExcelFile, objFso, objFile
strExcelFile = "D:\Mes Documents\Excel\Toto.xls"
Set objFso = CreateObject("Scripting.FileSystemObject")

On Error Resume Next
Set objFile = objFso.OpenTextFile(strExcelFile, ForAppending, TristateFalse)

If Err.Number <> 0 Then
MsgBox "Le fichier est déjà ouvert" & vbCrLf & Err.Number & vbCrLf _
           & Err.Source & vbCrLf & Err.Description: Err.Clear
 Else
   MsgBox "Le fichier n'est pas ouvert"
   Dim objExcel, objClasseur
   objFile.Close
   Set objExcel = CreateObject("Excel.Application")
   Set objClasseur = objExcel.Workbooks.Open(strExcelFile)
   objExcel.DisplayAlerts = False
   objExcel.Application.Visible = True 'False
   'MsgBox "fichier " & strExcelFile & " ouvert"
   'objExcel.Quit
   objExcel.Run ("Macro1") 'Exécute la macro de Excel ' La macro de excel copira les valeurs
   Set objExcel = Nothing
   Set objClasseur = Nothing
  
End If
Set objFile = Nothing
Set objFso = Nothing
'
'MsgBox "Fin "
'xlApp.Visible = True
End Sub
<hr size="2" width="100%" />Mais pour continuer, j'ai deux problemes :
1 - il faudrait que je puisse récuperer mes mariables a2, b2 et c2 de Word dans la macro de Excel.
2 - Mon fichier Toto.xls sera souvent déja ouvert. Je souhaiterais que si mon fichier Toto.xls est déja ouvert, il active celui-ci et execute la suite du programme.
Commenter la réponse de didieraucun
Messages postés
29
Date d'inscription
samedi 30 juin 2007
Statut
Membre
Dernière intervention
2 janvier 2008
0
Merci
Avec tous les aides que vous m'avez donné    , j'ai modifié le code comme suit :

Mais je n'arrive pas à trouver la solution pour :
1 - Activer le fichier "Toto.xls" si il est déjà ouvert ?
2 - Pour transferer la variable a2 de la macro Word "Test" dans la macro "Macro1" de Excel ?

<hr size= "2" width="100%" />Sub Test()
Dim a As String
Dim objExcel, objClasseur
Set objExcel = CreateObject("Excel.Application")

' Controle si le fichier Toto.xls est ouvert et l'ouvre si necessaireConst ForReading 1, ForWriting 2, ForAppending = 8Const TristateUseDefault -2, TristateTrue -1, TristateFalse = 0

Dim strExcelFile, objFso, objFile
strExcelFile = "D:\Mes Documents\Excel\Toto.xls"
Set objFso = CreateObject("Scripting.FileSystemObject")

On Error Resume Next
Set objFile = objFso.OpenTextFile(strExcelFile, ForAppending, TristateFalse)

If Err.Number <> 0 Then
MsgBox "Le fichier est déjà ouvert" & vbCrLf & Err.Number & vbCrLf _
           & Err.Source & vbCrLf & Err.Description: Err.Clear
          ' Que mettre ici pour aciver le fichier "Toto.xls" déjà ouvert ?
          
 Else
   MsgBox "Le fichier n'est pas ouvert"
      objFile.Close
      Set objClasseur = objExcel.Workbooks.Open(strExcelFile)
   'objExcel.DisplayAlerts = False
   objExcel.Application.Visible = True 'False
   'MsgBox "fichier " & strExcelFile & " ouvert"
   'objExcel.Quit
  
End If

' Partie 2 : Récupérer les valeurs du tableau Word sans les 2 derniers caractères bizarres
Set objTable = ActiveDocument.Tables(1)
a1 = Len(Mid(objTable.Cell(1, 1), 7, 25)) - 2
a2 = Mid(objTable.Cell(1, 1), 7, a1)

' partie 3 : Lance la macro "Macro1" de Excel
objExcel.Run ("Macro1") 'lance la macro de Excel
'objExcel.Cells(1, 1) = a2
' que mettre pour transferer la variable a2 dans la macro "Macro1" de Excel ?

'MsgBox a1 & " - " & a2

Set objExcel = Nothing
Set objClasseur = Nothing
Set objFile = Nothing
Set objFso = Nothing
End Sub
<hr size="2" width="100%" />
Commenter la réponse de didieraucun