Bonjour à tous

Donc je me décide de poster ce message en dernier recours.

Objectif de la macro:
Un doc word contient des tableaux des images, shémas, graphiques. Je dois récupérer les lignes des tableaux dont la premiere colonne contient une réfèrence ( UI-xxxxx-xxxx)

Ensuite exporter cela sous un document excel.
Je me suis basé sur des codes trouvés sur le forum
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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
 
Sub SRD_to_VTP()
'
'  Macro SRD_to_VTP
' Macro enregistrée le 09/03/2008 par GMAGNON
'
Dim WordDoc As Word.Document
Dim WordApp As Word.Application
Dim Wb, Wb2 As Workbook
Dim j As Byte
Dim tbl As Table
Dim FirstCell As Variant
Dim Result As Excel.Range
Dim Search As String
 
    Search = "ACS"
    Set Wb = Workbooks.Add(1)
    Set WordApp = New Word.Application
    WordApp.Visible = False
    Set WordDoc = WordApp.Documents.Open("D:\Download\HXX_SRD_4.doc", ReadOnly:=True)
 
    For Each tbl In WordApp.ActiveDocument.Tables
        tbl.Select
        WordApp.Selection.Copy
    Next tbl
 
    Wb.ActiveSheet.Range("A1").Select
    Wb.ActiveSheet.Paste
 
 
    Set Rg = Wb.ActiveSheet.Cells.Find(What:=Search, LookIn:=xlFormulas, _
                   LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                   MatchCase:=False)
    If Not (Rg Is Nothing) Then
        j = Rg.Row
        Wb.ActiveSheet.Rows(j).Copy
    End If
 
    'Recherche de tous les appels
    If Not Rg Is Nothing Then
        FirstCell = Rg.Address
        Do
            Set Rg = Wb.ActiveSheet.Cells.FindNext(Rg)
            If Not (Rg Is Nothing) Then
                j = Rg.Row
                Wb.ActiveSheet.Rows(j).Copy
            End If
        Loop While Not Rg Is Nothing And Rg.Address <> FirstCell
    End If
 
    Set Wb2 = Workbooks.Add(1)
    Wb2.ActiveSheet.Range("A1").Select
    Wb2.ActiveSheet.Paste
 
    WordApp.Application.Quit
    CutCopyMode = False
 
    Wb.SaveAs "D:\Download\ClasseurAll.xls"
    Wb2.SaveAs "D:\Download\ClasseurSearch.xls"
    'WordDoc.Close
    'WordApp.Quit
    Workbooks.Close
End Sub
Lorsque je lance la macro, il trouve une première ligne avec "ACS" ( recherche pour mes tests) dans la premiere colonne mais ne passe pas aux suivantes.

Merci de votre aide