Bonjour ,
Voila je viens vers vous pour un coup de pouce ...
j'ai un fichier qui est un dotm qui me permet de faire des fichier que je peu mettre dans divers dossier.
j'aimerais pouvoir faire ne sorte que ma const sois toujours valable.
je vous montre
a l'heure actuel j'ai
Code : Sélectionner tout - Visualiser dans une fenêtre à part
Private Const CFile As String = "R:\dd\DaE\Ia\S1\dossierjeune\note\"
j'aimerais retourner a deux dossier en arriere pour recupere un fichier dans
"R:\dd\DaE\Ia\S1\Transmission\"
j'ai essayer sa mais ça ne marche pas ^^"
Code : Sélectionner tout - Visualiser dans une fenêtre à part
Private Const CFile As String = "..\Transmission\"
et j'aimerais votre avis sur ma vba qui permet de recuperer les infirmation dans mon fichier transmission et les coller dans mon fichier. Sachant que les signet dans note sont générer par un autre fichier.
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
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.MoveUp Unit:=wdScreen, Count:=1000, Extend:=wdExtend
        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 d'avance et desoler si ce n'est pas clair.