VBA : Importation signets
Le
danielos

Bonjour à toutes et à tous,
La macro ci-dessous est censée rapatrier 4 mots non contigus et des
signets d'un document word dans un classeur excel.
Les signets sont bien présents dans le document word.
Le document est protégé (formulaire). Mais ça ne change rien que la=
protection soit enlevée ou pas.
Le texte entre les signets "Section1" et "Section1b" est bien importé
dans la cellule (1,dc) mais ensuite à la ligne Cells(2,dc) la macro =
plante en mettant le message d'erreur suivant :
Erreur d'exécution '5941' : Le membre de la collection requis n'existe =
pas.
Les références activées sont :
Visual Basic For Applications
Microsoft Excel 11.0 Object Library
OLE Automation
Microsoft Office 11.0 Object Library
Microsoft Word 11.0 Object Library
Malgré plusieurs essais de modifications du code, il y a toujours la
même erreur et je ne vois pas du tout d'où vient le problème. Si un=
e âme
charitable pouvait m'expliquer la source de cette erreur Je l'en
remercie grandement d'avance.
Sub recup_signets()
'variables
Dim wdApp As New Word.Application
Dim WordDoc As Word.Document
Dim FileToOpen
Dim n As Integer
Dim bm As String
Dim dc As Integer
Dim nbrows As Integer
'Ouverture document word
FileToOpen = Application.GetOpenFilename("Nom fichier,*.doc")
If FileToOpen = False Then
Exit Sub
Else
Set WordDoc = wdApp.Documents.Open(FileToOpen)
'wdApp.Visible = True
nbrows = ActiveDocument.Tables(1).Rows.Count - 1
On Error Resume Next
ActiveDocument.Unprotect
On Error GoTo 0
End If
'Recherche de la colonne utile
Sheets("List_Signet").Select
Range("A1").Select
dc = Sheets("List_Signet").Range("IV1").End(xlToLeft).Column + 1
'Importation texte 1
Cells(1, dc) = WordDoc.Range(WordDoc.Bookmarks("Section1").Range.Start,=
WordDoc.Bookmarks("Section1b").Range.End).Text
'Beauté
Sheets("List_Signet").Columns(dc).EntireColumn.AutoFit
'Importation des 3 autres textes (si présents)
If nbrows = 0 Then GoTo saute
Cells(2, dc) = WordDoc.Range(WordDoc.Bookmarks("Nb1").Range.Start,
WordDoc.Bookmarks("Nb1b").Range.End).Text
Cells(3, dc) = WordDoc.Range(WordDoc.Bookmarks("Nb2").Range.Start,
WordDoc.Bookmarks("Nb2b").Range.End).Text
Cells(4, dc) = WordDoc.Range(WordDoc.Bookmarks("Nb3").Range.Start,
WordDoc.Bookmarks("Nb3b").Range.End).Text
saute:
'Importation des autres signets
For n = 5 To 104
bm = Cells(n, 2).Value
Cells(n, dc) = WordDoc.Bookmarks(bm).Range.Text
Next n
'Quitte Word
Set WordDoc = Nothing
wdApp.Quit
Set wdApp = Nothing
End Sub
Merci pour l'aide à un blaireau en détresse.
Daniel
La macro ci-dessous est censée rapatrier 4 mots non contigus et des
signets d'un document word dans un classeur excel.
Les signets sont bien présents dans le document word.
Le document est protégé (formulaire). Mais ça ne change rien que la=
protection soit enlevée ou pas.
Le texte entre les signets "Section1" et "Section1b" est bien importé
dans la cellule (1,dc) mais ensuite à la ligne Cells(2,dc) la macro =
plante en mettant le message d'erreur suivant :
Erreur d'exécution '5941' : Le membre de la collection requis n'existe =
pas.
Les références activées sont :
Visual Basic For Applications
Microsoft Excel 11.0 Object Library
OLE Automation
Microsoft Office 11.0 Object Library
Microsoft Word 11.0 Object Library
Malgré plusieurs essais de modifications du code, il y a toujours la
même erreur et je ne vois pas du tout d'où vient le problème. Si un=
e âme
charitable pouvait m'expliquer la source de cette erreur Je l'en
remercie grandement d'avance.
Sub recup_signets()
'variables
Dim wdApp As New Word.Application
Dim WordDoc As Word.Document
Dim FileToOpen
Dim n As Integer
Dim bm As String
Dim dc As Integer
Dim nbrows As Integer
'Ouverture document word
FileToOpen = Application.GetOpenFilename("Nom fichier,*.doc")
If FileToOpen = False Then
Exit Sub
Else
Set WordDoc = wdApp.Documents.Open(FileToOpen)
'wdApp.Visible = True
nbrows = ActiveDocument.Tables(1).Rows.Count - 1
On Error Resume Next
ActiveDocument.Unprotect
On Error GoTo 0
End If
'Recherche de la colonne utile
Sheets("List_Signet").Select
Range("A1").Select
dc = Sheets("List_Signet").Range("IV1").End(xlToLeft).Column + 1
'Importation texte 1
Cells(1, dc) = WordDoc.Range(WordDoc.Bookmarks("Section1").Range.Start,=
WordDoc.Bookmarks("Section1b").Range.End).Text
'Beauté
Sheets("List_Signet").Columns(dc).EntireColumn.AutoFit
'Importation des 3 autres textes (si présents)
If nbrows = 0 Then GoTo saute
Cells(2, dc) = WordDoc.Range(WordDoc.Bookmarks("Nb1").Range.Start,
WordDoc.Bookmarks("Nb1b").Range.End).Text
Cells(3, dc) = WordDoc.Range(WordDoc.Bookmarks("Nb2").Range.Start,
WordDoc.Bookmarks("Nb2b").Range.End).Text
Cells(4, dc) = WordDoc.Range(WordDoc.Bookmarks("Nb3").Range.Start,
WordDoc.Bookmarks("Nb3b").Range.End).Text
saute:
'Importation des autres signets
For n = 5 To 104
bm = Cells(n, 2).Value
Cells(n, dc) = WordDoc.Bookmarks(bm).Range.Text
Next n
'Quitte Word
Set WordDoc = Nothing
wdApp.Quit
Set wdApp = Nothing
End Sub
Merci pour l'aide à un blaireau en détresse.
Daniel
'------------------------------
On Error Resume Next
ActiveDocument.Unprotect
On Error GoTo 0
'------------------------------
Remplace ce qui précède par ceci :
WordDoc.Unprotect
Si tu désactives la gestion d'erreur, la procédure va t'indiquer quelle ligne de code est
problématique.
Es-tu certain que tous les signets de ta procédure existent bien dans le document que tu ouvres?
Que va-t-il se passer si une des cellules est vide ou ne représente pas un signet ici dans ton code?
bm = Cells(n, 2).Value
Cells(n, dc) = WordDoc.Bookmarks(bm).Range.Text
réponses à tes questions.
MichD a écrit :
Bonsoir MichD
C'est la ligne qui commence par Cells(2,dc)=....
Oui ils y sont bien tous
Si un signet est vide .... Rien il n'y aura rien dans la cellule du
classeur.
S'il manque un signet... la macro plante sur la ligne ;
"Cells(n, dc) = WordDoc.Bookmarks(bm).Range.Text"
avec le même message d'erreur :
Erreur d'exécution '5941' : Le membre de la collection requis n'existe pas
Je vais donc regarder encore du côté de mes signets.
Merci de la piste ;-)
dans le code. "Nb1b" à la place de "N1b".
grrrhh ; tant d'heures à chercher. Merci MichD pour m'avoir mis sur la
piste.
Bonne soirée à toutes te à tous.
danielos a écrit :
Dim Bk As Word.Bookmark, A As Long
For Each Bk In WordDoc.Bookmarks
With worksheets("Feuil1") 'Onglet feuille à adapter
A = A + 1
'Adresse première cellule à adapter
.Range("A" & A) = Bk.Range.Text
End With
Next