[XL-2010] Probleme Extraction cellules Word vers Excel

Bonjour,

J'ai realisé une macro pour extraire par mots cles quelques celulles word vers Excle mais quand je l essaie sur excel ce dernier bug
STP tu me dire ou le probleme ? :cry:

vous trouverez en bas du code le fichier word a extraire ci joint

Mercii :ccool:

Code:

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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
 
Sub Macro()
   'nécessite d'activer la référence
        'Microsoft Word xx.x Object Library
    Dim WordApp As Object
    Dim WordDoc As Object
    Dim Fichier As String
    Dim themes(6)
    Dim valeur As String
 
    'le document Word est supposé fermé avant le lancement de la macro
    Fichier = "E:\Produits logiciels.doc"
 
    'creation session Word
    Set WordApp = CreateObject("Word.Application")
 
    'pour que word reste masqué pendant l'opération
    WordApp.Visible = False
 
    'ouverture du fichier Word
    Set WordDoc = WordApp.Documents.Open(Fichier)
'
themes(1) = "système d'exploitation"
themes(2) = "Base de données"
themes(3) = "WAS, Serveurs Web"
themes(4) = "Service d'infrastructure"
themes(5) = "Environnement de développement"
themes(6) = "Autres"
 
For i = 1 To UBound(themes)   'Boucle sur les Themes
 
    With WordApp.Selection.Find
        .Replacement.ClearFormatting
        .ClearFormatting
        .Text = themes(i)
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute
 
    End With
 
    'With WordApp.Selection.Find
 
     Selection.Find.Execute
    'While Selection.Find.Found
        'With Selection
 
 With WordApp.Selection
 
'Pour tous les Theme
        .MoveRight Unit:=wdCell
        valeur = Replace(.Selection, Chr(13), Chr(10))
        ActiveSheet.Cells(i + 1, 1) = valeur
 
'Pour les Theme (1 2 3 5 6)
        If i <> 4 Then
            .MoveRight Unit:=wdCell
            valeur = Replace(.Selection, Chr(13), Chr(10))
            ActiveSheet.Cells(i + 1, 2) = valeur
        End If
 
'Pour le Theme 5
        If i = 5 Then
            .MoveRight Unit:=wdCell, Count:=3
            valeur = Replace(.Selection, Chr(13), Chr(10))
            ActiveSheet.Cells(i + 1, 3) = valeur
 
            .MoveRight Unit:=wdCell
            valeur = Replace(.Selection, Chr(13), Chr(10))
            ActiveSheet.Cells(i + 1, 4) = valeur
 
        End If
    End With
Next i
 
WordApp.Quit
End Sub