Bonjour,
J'ai trouvé sur ce site
une requête qui permet d'extraire automatiquement des données de nombreux documents Word vers Excel.
Elle fonctionne très bien, mais je n'arrive pas à l'adapter à mon cas particulier.
En effet,
Apparemment, mon problème se situe au niveau de :
que j'ai mis moi-même, mais je ne sais pas comment faire pour que ça fonctionne.
Merci d'avance pour votre aide.
Cordialement.
J'ai trouvé sur ce site
HTML:
http://www.gcexcel.com/vba-importer-des-donnees-de-word-vers-excel/
une requête qui permet d'extraire automatiquement des données de nombreux documents Word vers Excel.
Elle fonctionne très bien, mais je n'arrive pas à l'adapter à mon cas particulier.
En effet,
Code:
Option Explicit
' ----------------------------------------------------------------
' Extraction des données à partir de fichier Word vers Excel
' Par : Grand Chaman Excel -- 2013/03/05
'-----------------------------------------------------------------
Sub Importation_Donnees_Word()
' -- Déclaration des variables
Dim wb As Workbook 'classeur Excel dans lequel on importe les données
Dim ws As Worksheet 'onglet Excel dans lequel on importe les données
Dim sChemin As String 'répertoire contenant les fichiers Word
Dim sNomFichier As String 'nom du fichier Word
Dim WApp As Object, WDoc As Object, WSel As Object
Dim i As Integer
' -- Initialisation des variables
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) 'on sauvegarde dans la 1re feuille
sChemin = ChoisirRepertoire & "\" 'fonction pour choisir le répertoire contenant les fichier Word
'sChemin = ThisWorkbook.Path & "\" 'si les fichiers Word se trouvent dans le même répertoire que le fichier Excel
sNomFichier = Dir(sChemin & "*.doc*") 'pour ouvrir tous les fichiers .doc*. 1er fichier.
Set WApp = CreateObject("Word.Application") 'pour créer un objet Word
WApp.Visible = True 'ne pas afficher Word pendant l'exécution
i = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 '1re ligne où on va écrire les données dans le fichier Excel
Application.ScreenUpdating = False
' -- Boucle sur les fichiers
Do While Len(sNomFichier) > 0
Set WDoc = WApp.Documents.Open(sChemin & sNomFichier) 'ouvre le document Word
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect "titi" ' enlève le mot de passe du document Word
End If
Application.StatusBar = "Écriture ligne " & i 'message dans Excel pour voir la progression
' Nom du fichier
ws.Cells(i, 1) = sNomFichier
' Date (par la fonction FIND)
WApp.Selection.HomeKey unit:=6 'Retourne au début du fichier Word
WApp.Selection.Find.ClearFormatting 'on "vide la mémoire" de la fonction Recherche
WApp.Selection.Find.Execute "Date" 'On trouve le texte "Date"
WApp.Selection.MoveRight unit:=3, Count:=2, Extend:=2 'On se déplace de 3 mots
Set WSel = WApp.Selection 'sélection du texte trouvé
WApp.Selection.Copy
ws.Cells(i, 2).Paste (xlPasteValues)
' Numéro d'opérateur (par la fonction FIND)
WApp.Selection.HomeKey unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "Numéro d'opérateur"
WApp.Selection.MoveRight unit:=3, Count:=2, Extend:=1
Set WSel = WApp.Selection
WApp.Selection.Copy
ws.Cells(i, 3).Paste (xlPasteValues)
' Montant anomalie (par la fonction FIND)
WApp.Selection.HomeKey unit:=6
WApp.Selection.Find.ClearFormatting
WApp.Selection.Find.Execute "Montant anomalie"
WApp.Selection.MoveRight unit:=3, Count:=2, Extend:=1
Set WSel = WApp.Selection
WApp.Selection.Copy
ws.Cells(i, 4).Paste (xlPasteValues)
i = i + 1 'prochaine ligne
WDoc.Close False 'fermer le document Word en l'enregistrant
sNomFichier = Dir 'prochain document
Loop
SortieNormale:
Application.ScreenUpdating = True
WApp.Quit 'Fermer l'instance de Word
Application.StatusBar = False 'Remise à zéro de la barre d'état
End Sub
Function ChoisirRepertoire() As String
' -- Fonction permettant de choisir un répertoire
Dim oRepertoire As Object
ChoisirRepertoire = ""
Set oRepertoire = CreateObject("Shell.Application").BrowseForFolder(0, "Choisir un répertoire", 0)
If (Not oRepertoire Is Nothing) Then ChoisirRepertoire = oRepertoire.Items.Item.Path
Set oRepertoire = Nothing
End Function
Apparemment, mon problème se situe au niveau de :
Code:
WApp.Selection.Copy
ws.Cells(i, 4).Paste (xlPasteValues)
que j'ai mis moi-même, mais je ne sais pas comment faire pour que ça fonctionne.
Merci d'avance pour votre aide.
Cordialement.