1. Accueil
  2. Forum Codes-Sources
  3. Visual Basic
  4. Visual Basic 6
Sujet Précédent Sujet Suivant

VBA - Transferer des valeurs de Word vers Excel

Résolu
didieraucun Messages postés 29 Date d'inscription samedi 30 juin 2007 Statut Membre Dernière intervention 2 janvier 2008 - 30 juin 2007 à 11:33
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 

8 réponses

Réponse 1 / 8
cs_JMO Messages postés 1854 Date d'inscription jeudi 23 mai 2002 Statut Membre Dernière intervention 24 juin 2018 26
1 juil. 2007 à 22:20
 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
3
Réponse 2 / 8
cs_JMO Messages postés 1854 Date d'inscription jeudi 23 mai 2002 Statut Membre Dernière intervention 24 juin 2018 26
3 juil. 2007 à 20:39
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
3
Réponse 3 / 8
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
Fin du post


<hr size="2" width="100%" />
La suite ici
3
Réponse 4 / 8
didieraucun Messages postés 29 Date d'inscription samedi 30 juin 2007 Statut Membre Dernière intervention 2 janvier 2008
2 juil. 2007 à 19:51
Merci ... j'ai une erreur de compilation
0

Vous n’avez pas trouvé la réponse que vous recherchez ?

Posez votre question
Réponse 5 / 8
didieraucun Messages postés 29 Date d'inscription samedi 30 juin 2007 Statut Membre Dernière intervention 2 janvier 2008
3 juil. 2007 à 23:07
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%" />
0
Réponse 6 / 8
cs_JMO Messages postés 1854 Date d'inscription jeudi 23 mai 2002 Statut Membre Dernière intervention 24 juin 2018 26
4 juil. 2007 à 10:35
 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
0
Réponse 7 / 8
didieraucun Messages postés 29 Date d'inscription samedi 30 juin 2007 Statut Membre Dernière intervention 2 janvier 2008
4 juil. 2007 à 21:47
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.
0
Réponse 8 / 8
didieraucun Messages postés 29 Date d'inscription samedi 30 juin 2007 Statut Membre Dernière intervention 2 janvier 2008
5 juil. 2007 à 20:51
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%" />
0
Rejoignez-nous