Discussion :

[hajar1403]

Bonjour, je me permet de poser ma question sur ce forum parce que je n'arrive pas à trouver une solution à mon problème et ma question est dans l'intitulé de la discussion, je m'explique : je voudrais chercher un mot clé dans mon document une fois trouvé (se trouve forcement dans un tableau) copier le contenu de la cellule en face et le coller ailleur.
cela va être fait pour plusieurs cellule c pour cela la macro.
Merci d'avance

[Invité]

Bonjour,

Une solution possible à partir d'Excel :

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
 
Sub TestRecupererChaine()
 
    MsgBox RecupererChaine("C:\Users\......\MonFichierWord.docm", "B")  ' A adapter
 
End Sub
 
Function RecupererChaine(ByVal CheminComplet As String, ByVal TexteATrouver As String) As String
 
' Référencer la DLL Microsoft Word
 
Dim wApp As Word.Application       'As Object
Dim DocAModifier As Word.document  'As Object
Dim I As Integer, J As Integer
Dim Continuer As Boolean
 
   ' Application.ScreenUpdating = False
    RecupererChaine = ""
 
    Set wApp = CreateObject("Word.Application")
    With wApp
         .Visible = True
         Set DocAModifier = .Documents.Open(Filename:=CheminComplet)
         With DocAModifier
 
              If .Tables.Count > 0 Then
                 For I = 1 To .Tables.Count
                     Continuer = True
                     For J = 1 To .Tables(I).Columns(1).Cells.Count
                       With .Tables(I).Columns(1).Cells(J)
                         If InStr(1, .Range.Text, TexteATrouver, vbTextCompare) > 0 Then
                            RecupererChaine = Mid(DocAModifier.Tables(I).Columns(2).Cells(J).Range.Text, 1, Len(DocAModifier.Tables(I).Columns(2).Cells(J).Range.Text) - 1)
                            Continuer = False
                         End If
                       End With
                     Next J
                     If Continuer = False Then Exit For
                 Next I
              End If
              .Close
        End With
        .Quit
    End With
 
    Set DocAModifier = Nothing
    Set wApp = Nothing
 
   ' Application.ScreenUpdating = True
 
End Function