Discussion :

[ZibOne]

Bonjour,

Je vous contacte car j'ai (re) "bidouiller" quelque chose.. qui évidemment ne fonctionne pas terrible

l'idée est d'ouvrir un premier doc word contenu dans un dossier (dont le chemin d'accès est spécifié dans une cellule de mon Excel)
puis de vérifier le nombre d'occurence d'un premier mot
puis de renseigner ce décompte dans une cellule spécifique du tableau de suivi des occurences du document word
et de passer au prochain doc word

mon premier problème est que je mélange des concepts (ce qui ne passe pas en VBA) et génère une erreur ici :

code :

Workbooks.Open Filename:=ThisWorkbook.Sheets("Macros").Range("I16").Value & "\" & ThisWorkbook.Sheets("Liste des docs words analysés").Cells(j, 1).Value

mon second problème est que je voudrais récupérer les 18 derniers caractères précédent le ".docx" sachant qu'à ce stade (lorsque la boucle fonctionnait un minimum) étaient pris en compte le document pdf associé à ce même word (que je garde dans le même dossier)..

Je remercie par avance l'âme généreuse qui daignera m'apporter son aide.

Voici mon code

Code :

Sub Compter()

Dim n As Integer
n = ThisWorkbook.Sheets("Wordings").Cells(1, 10000).End(xlToLeft).Column

Dim k As Integer
k = ThisWorkbook.Sheets("Liste des docs words analysés").Cells(60000, 1).End(xlUp).Row

Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Macros")

Dim word_path As String
word_path = sh.Range("I16").Value

Dim fso As New FileSystemObject
Dim fo As Folder
Dim f As File
Dim WordApp As Word.Application
Dim doc As Object

Dim wa As Object
Set wa = CreateObject("Word.Application")

Set fo = fso.GetFolder(word_path)
Dim file_count As Integer

Count = 0

For i = 7 To n

For j = 1 To k

file_count = 0

For Each f In fo.Files
Application.DisplayAlerts = False
'Set doc = wa.Documents.Open(f.Path, ReadOnly = True)

Workbooks.Open Filename:=ThisWorkbook.Sheets("Macros").Range("I16").Value & "\" & ThisWorkbook.Sheets("Liste des docs words analysés").Cells(j, 1).Value

searchtext$ = Sheets("Wordings").Cells(1, i).Value

With doc.Content.Find
Do While .Execute(findText:=searchtext$, Format:=False, MatchCase:=False, MatchWholeWord:=True) = True
Count = Count + 1
Loop
End With

Dim zed As Integer
zed = ThisWorkbook.Sheets("Wordings").Cells(60000, 7).End(xlUp).Row

ThisWorkbook.Sheets("Wordings").Cells(zed + 1, i).Value = Count
ThisWorkbook.Sheets("Wordings").Cells(zed + 1, 5).Value = Right(ActiveDocument.doc, 18)

doc.Close True

Next

Next j

Next i

[EricDgn]

Bonjour,

Une façon de faire, ici n'utilisant que la feuille Wordings et en y plaçant le nom du dossier en A1 et les mots à chercher en B1, C1, et ainsi de suite en ligne 1:

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Option Explicit
 
Sub Compter()
    Dim wsW As Worksheet
    Dim kC As Long, kR As Long, k As Long
    Dim wdApp As Object, wdPath As String, wdFile As String
    Dim wdDoc As Object, wdText As String, n As Long
 
    Set wsW = ThisWorkbook.Sheets("Wordings")
    wsW.Select
 
    kC = wsW.Cells(1, wsW.Columns.Count).End(xlToLeft).Column   '--- colonne dernier mot
    kR = wsW.Cells(wsW.Rows.Count, 1).End(xlUp).Row             '--- dernière ligne utilisée
    wdPath = wsW.Range("A1") & "\"
 
    Set wdApp = CreateObject("Word.Application")
    'wdApp.Visible = True
    'wdApp.Activate
    'wdApp.WindowState = wdWindowStateNormal
 
    wdFile = Dir(wdPath & "*.docx")
    While wdFile <> ""
        kR = kR + 1
        wsW.Cells(kR, 1) = wdFile
        Set wdDoc = wdApp.documents.Open(wdPath & wdFile)
        For k = 2 To kC
            wdText = wsW.Cells(1, k)
            n = 0
            With wdDoc.Content.Find
                Do While .Execute(findText:=wdText, Format:=False, MatchCase:=False, MatchWholeWord:=True) = True
                    n = n + 1
                Loop
            End With
            wsW.Cells(kR, k) = n
        Next k
        wdDoc.Close SaveChanges:=False
        wdFile = Dir
    Wend
 
    wdApp.Quit
    Set wdDoc = Nothing
    Set wdApp = Nothing
 
    wsW.Cells(kR, 1).Select
    MsgBox "Terminé"
End Sub

Cordialement.