Discussion :

[keranLatos]

Bonjour ,

Voila je voudrais savoir comment je pourrais faire en vba que ma selection parte de ma recherche au haut du document . merci

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
    With Selection.Find
        .Text = datearive
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
        Selection.Find.Execute
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.MoveUp Unit:=wdScreen, Count:=2000, Extend:=wdExtend
        Selection.Copy
     End With

[Invité]

Bonjour,

En mettant avant With Selection.Find :

Code :

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

1
2
 
   Selection.HomeKey unit:=wdStory

[keranLatos]

bonjour , merci je regarde cela de suite

[keranLatos]

j'ai essayer mais je n'est pas reussi je voulais savoir si quelque chose comme cela pourrais marcher

Code :

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

'Selection.MoveUp Unit:=wdGoToLine, Count:=wdGoToFirst, Extend:=wdExtend

[Invité]

Si c'est tout le document qui est à sélectionner :

Code :

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

1
2
 
   ActiveDocument.Range.Select

[keranLatos]

hum ce n'est qu'une patie du document il part d'une date et remonte jusqu'en haut du document ^^" je pense pas etre tres clair mais je ne sais pas comment dire autrement

[Invité]

Alors :

Code :

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

1
2
 
   Selection.HomeKey unit:=wdStory, Extend:=wdExtend

[keranLatos]

U_u tellement .. que je me ridiculise merci !

[keranLatos]

juste comme cela vous auriez une idee pour copier une grosse quantiter de page (100+/-) d'un document a un autre sans buguer ?.

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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
Option Explicit
Private Const CFile As String = "C:\Users\Bu\Desktop\divers\Ressources\Admission\"
Private Const CFile2 As String = "C:\Users\Bu\Desktop\divers\"
Private Const service As String = " 7ans"
Private Const Chef As String = "Aurdy"
Public DocEnCours As Document
Public HeureArrêt As Date
Public heure
Public Continuer As Boolean
Public Cherche As String
Private Sub Lancer_Click()
Dim i As Integer, j As Integer
Dim prenom As String, Nom As String, datearive As String _
, file As String, file1 As String, file2 As String, file3 As String _
, file4 As String, file5 As String, file6 As String, date2 As String, FichierWord
Dim oTbl As Table
 
Set oTbl = ActiveDocument.Tables(1)
datearive = netText(oTbl.Cell(1, 3).Range.Text)
prenom = netText(oTbl.Cell(1, 2).Range.Text)
Nom = netText(oTbl.Cell(1, 1).Range.Text)
 
 
file = CFile & Nom & " " & prenom & "\Notes\"
file1 = "Observation de " & Nom & " " & prenom & ".docm"
file2 = CFile & "Recup.dotm"
file3 = CFile2 & "Transmission.docm"
file5 = CFile & "\Notes\recup2.docm"
file6 = CFile & "\Notes\Observation de " & Nom & " " & prenom & ".docm"
 
 
On Error Resume Next
 
 
    ActiveDocument.Tables(1).Rows(1).Cells(1).Select
    Selection.Range.Case = wdLowerCase
    Selection.EndKey Unit:=wdLine
    Selection.TypeBackspace
 
    ActiveDocument.Tables(1).Rows(1).Cells(3).Select
    Selection.EndKey Unit:=wdLine
    Selection.TypeBackspace
 
    ActiveDocument.Tables(1).Rows(1).Cells(2).Select
    Selection.Range.Case = wdLowerCase
    Selection.EndKey Unit:=wdLine
    Selection.TypeBackspace
 
Set FichierWord = GetObject(file3)
If FichierWord = ActiveDocument Then
    Else
    Documents.Open FileName:=file3
End If
 
     With Documents("Transmission.docm")
     Application.ScreenUpdating = False
     .Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = datearive
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
        Selection.Find.Execute
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
        Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
        Selection.Copy
         Application.ScreenUpdating = True
     End With
 
     Documents.Open FileName:=file2
        ChangeFileOpenDirectory _
        file
        ActiveDocument.SaveAs2 FileName:="recup.docm", _
        FileFormat:=wdFormatXMLDocumentMacroEnabled
 
      With Documents("recup.docm")
      Application.ScreenUpdating = False
      Selection.Paste
           For i = 1 To .Paragraphs.Count
               .Paragraphs(i).Range.Select
               If InStr(1, Selection.Text, prenom, vbTextCompare) > 0 Then
                  Selection.Copy
                  With Documents("Observation de " & Nom & " " & prenom & ".docm")
                       .Select
                        With Selection
                          Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst, Count:=7, Name:=""
                          Selection.Range.Paste
                       End With
                        Application.ScreenUpdating = True
                  End With
                End If
           Next i
     End With
         With Documents("Observation de " & Nom & " " & prenom & ".docm")
           For i = 1 To .Paragraphs.Count
               .Paragraphs(i).Range.Select
               If InStr(1, Selection.Text, "Présent", vbTextCompare) > 0 Then
                  Selection.Delete
                End If
           Next i
                For j = 1 To .Paragraphs.Count
                .Paragraphs(j).Range.Select
                 If InStr(1, Selection.Text, "Extérieur", vbTextCompare) > 0 Then
                 Selection.Delete
                End If
           Next j
     End With
     Documents("recup.docm").Close SaveChanges:=wdDoNotSaveChanges
     Kill (file & "recup.docm")
 
End Sub
Public Function netText(stTemp As String)
    netText = Left(stTemp, (Len(stTemp) - 2))
End Function

merci

[Invité]

A quel endroit cela bugue ?