Sub PageSignetWord()
Dim chemin$, NomDoc$, NomSignet$, WDoc As Object, NumPage%
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
NomSignet = "MonSignet" 'à adaptet
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
NumPage = WDoc.Bookmarks(NomSignet).Range.Information(3) '3 => wdActiveEndPageNumber
MsgBox "Le signet '" & NomSignet & "' " & IIf(NumPage, "se trouve page " & NumPage, "est introuvable...")
WDoc.Close False
End Sub
Sub ListeSignetsWord()
Dim chemin$, NomDoc$, NomSignet$, WDoc As Object, lig&, bm As Object
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
Application.ScreenUpdating = False
[A:B].ClearContents 'RAZ
[A1] = "Signet": [B1] = "Page": lig = 1
For Each bm In WDoc.Bookmarks
lig = lig + 1
Cells(lig, 1) = bm.Name
Cells(lig, 2) = bm.Range.Information(3) '3 => wdActiveEndPageNumber
Next
WDoc.Close False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim mot$, chemin$, NomDoc$, WDoc As Object, d As Object, w As Object, p%, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
mot = CStr([D2])
If mot <> "" Then
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
Set d = CreateObject("Scripting.Dictionary")
For Each w In WDoc.Words
If Trim(w.Text) = mot Then
p = w.Information(3) '3 => wdActiveEndPageNumber
d(p) = d(p) + 1 'comptage
End If
Next
WDoc.Close False
'---restitution---
n = d.Count
If n Then
If FilterMode Then ShowAllData 'si la feuille est filtrée
[C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
[D5].Resize(n) = Application.Transpose(d.items)
End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim texte$, L%, chemin$, NomDoc$, WDoc As Object, d As Object, w As Object, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
texte = CStr([D2]): L = Len(texte)
If texte <> "" Then
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
Set d = CreateObject("Scripting.Dictionary")
For Each w In WDoc.Words
If Not texte Like Trim(w.Text) & "*" Then GoTo 1
If WDoc.Range(w.Start, w.Start + L) <> texte Then GoTo 1
n = w.Information(3) '3 => wdActiveEndPageNumber
d(n) = d(n) + 1 'comptage
1 Next
WDoc.Close False
'---restitution---
n = d.Count
If n Then
If FilterMode Then ShowAllData 'si la feuille est filtrée
[C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
[D5].Resize(n) = Application.Transpose(d.items)
End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim texte$, chemin$, NomDoc$, WDoc As Object, d As Object, deb&, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
texte = CStr([D2])
If texte <> "" Then
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
On Error GoTo 0
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
Set d = CreateObject("Scripting.Dictionary")
Do
With WDoc.Range(deb).Find
.Text = texte
.Forward = True
.Execute
If Not .Found Then Exit Do
n = .Parent.Information(3) '3 => wdActiveEndPageNumber
d(n) = d(n) + 1 'comptage
deb = .Parent.End
End With
Loop
WDoc.Close False
'---restitution---
n = d.Count
If n Then
If FilterMode Then ShowAllData 'si la feuille est filtrée
[C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
[D5].Resize(n) = Application.Transpose(d.items)
End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim texte$, L%, chemin$, NomDoc$, WDoc As Object, d As Object, wdc$, deb&, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
texte = CStr([D2]): L = Len(texte)
If texte <> "" Then
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
On Error GoTo 0
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
Set d = CreateObject("Scripting.Dictionary")
wdc = Replace(WDoc.Content, vbCr & Chr(7), vbCr) 'épuration nécessaire s'il y a des tableaux
deb = 1 - L
Do
deb = InStr(deb + L, wdc, texte)
If deb = 0 Then Exit Do
n = WDoc.Range(deb - 1, deb + L - 1).Information(3) '3 => wdActiveEndPageNumber
d(n) = d(n) + 1 'comptage
Loop
WDoc.Close False
'---restitution---
n = d.Count
If n Then
If FilterMode Then ShowAllData 'si la feuille est filtrée
[C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
[D5].Resize(n) = Application.Transpose(d.items)
End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub
Set WDoc = GetObject(ThisWorkbook.Path & "\MonDoc.docx")
WDoc.Close False
With WDoc.Range(deb, deb).Find