Discussion :

[PhoeniX1405]

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

[zandru]

Bonjour,
si je comprend bien ce que tu veux faire, il faudrait coller chaque ligne que tu copie. A l'heure actuelle, tu colles uniquement après avoir copié toutes les lignes que tu veux ; donc tu ne colles que le dernier copié.

essai ceci :

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
    'Recherche de tous les appels
    Set Wb2 = Workbooks.Add(1)
    If Not Rg Is Nothing Then
        FirstCell = Rg.Address
        Dim ligne As Integer
        ligne = 1
        Do
            Set Rg = Wb.ActiveSheet.Cells.FindNext(Rg)
            If Not (Rg Is Nothing) Then
                j = Rg.Row
                Wb.ActiveSheet.Rows(j).Copy
                Wb2.ActiveSheet.Range("A" & ligne).Select
                Wb2.ActiveSheet.Paste
                ligne = ligne + 1
            End If
        Loop While Not Rg Is Nothing And Rg.Address <> FirstCell
    End If

qu'en pense tu ?

[PhoeniX1405]

Avant toute chose merci de ta réponse Zandru.

Le problème vient plutôt du findnext. Donc par exemple :

col1 col2 colx ...
ACS ref1
ACS ref2
ACS ref3


Actuellement mon fichier ClasseurSearch ne contient que
ACS ref1

Lorsque j'exécute la macro "pas à pas", la boucle contenant le FindNext n'est exécutée qu'une seule fois... et ne passe donc pas aux lignes suivantes.

J'espère avoir été plus clair sur mon problème.

Merci

Donc je suis toujours bloqué sur ce problème, si on pouvait m'assister pour poser la pierre suivante.

Merci de votre aide