Bonjour,

J'ai un petit problème sur cette macro qui fonctionne trés bien lors de la première exécution, mais qui plante lors de la seconde au niveau de la ligne en gras.
Le debogeur renvoir l'erreur '462', "Le serveur distant n'existe pas ou n'est pas disponible."
De plus, si je clique sur 'annuler' lorsque la fenêtre d'enregistrement s'ouvre, le code met pas mal de temps à finir de s'exécuter.
La macro est exécutée depuis un fichier excel.

Merci de votre aide

PS : J'ai modifié le code car je ne peux le communiquer d'où les noms de variables.
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
Public Sub Macro()
    'Chemins d'accés
    Dim Template_Path As String, Folder_Path As String, ExcelFileDoc1_Path As String
    Folder_Path = ThisWorkbook.Worksheets("Conf").Range("B2")
    ExcelFileDoc1_Path = ThisWorkbook.Worksheets("Conf").Range("B1")
    Template_Path = ThisWorkbook.Worksheets("Conf").Range("B8")
    
    'Sélection du répertoire
    Application.FileDialog(msoFileDialogFolderPicker).InitialFileName = Folder_Path
    Application.FileDialog(msoFileDialogFolderPicker).Title = "Select Folder"
    Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False
    If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then
        Folder = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
    Else
        Enda
    End If

    Dim ListeFiles As New Collection, FilesInFolder As String
    FilesInFolder = Dir(Folder & "\")
    Do While FilesInFolder <> ""
        ListeFiles.Add FilesInFolder
        FilesInFolder = Dir()
    Loop
    
    'Recherche du fichier ExcelFileDoc2
    For Each ExcelFileDoc2 In ListeFiles
        If (InStr(1, ExcelFileDoc2, "Excel_doc2") <> 0) And (InStr(1, ExcelFileDoc2, ".xls") <> 0) Then
            Exit For
        End If
    Next
               
    'Ouverture du fichier Word
    Dim Wordapp As New Word.Application, WordDoc As Document
    Set WordDoc = Wordapp.Documents.Open(ThisWorkbook.path & "\" & Template_Path, ReadOnly:=False)
    Wordapp.Visible = True
        
    'Ouverture fichier ExcelDoc1
    Dim ExcelDoc1 As New Workbook
    Set ExcelDoc1 = Workbooks.Open(ExcelFileDoc1_Path, ReadOnly:=True)
    Windows(ExcelDoc1.Name).Visible = True
    
    'Ouverture du fichier ExcelDoc2
    Dim ExcelDoc2 As New Workbook
    Set ExcelDoc2 = Workbooks.Open(Folder & "\" & ExcelFileDoc2, ReadOnly:=True)
    Windows(ExcelDoc2.Name).Visible = True
    
    'Récupération nom
    Dim Nom As String
    Nom = Split(Folder, " - ")(1)
    Nom = Mid(Nom, 4, 3)
    
    'Informations dans le fichier ExcelDoc1
    Dim NomCell, WordDocReferenceCell
    
    Set NomCell = ExcelDoc1.Sheets("Sheet1").Columns(1).Cells.Find(what:=Nom)
    Set WordDocReferenceCell = ExcelDoc1.Sheets("Sheet1").Cells.Find(what:="WordDoc")

    Dim Reference As String
    Reference = ExcelDoc1.Sheets("Sheet1").Cells(NomCell.Row, WordDocReferenceCell.Column)
    
    'Remplissage WORD
    WordDoc.CustomDocumentProperties.Item("A_Reference") = Reference
    SearchAndReplace "<Nom>", Nom, WordDoc
    
    'Maj des champs
    maj_champs WordDoc

    'Fermetures des fichiers
    ExcelDoc2.Close SaveChanges:=False
    ExcelDoc1.Close SaveChanges:=False

    'Sauvegarde du fichier WordDoc
    Dim rep As FileDialog
    
    Set rep = Word.Application.FileDialog(msoFileDialogSaveAs)
    rep.AllowMultiSelect = False
    rep.Title = "Enregistrer le fichier sous..."
    rep.InitialFileName = Folder & Nom
    rep.FilterIndex = 2 'format .docm
    If rep.Show = -1 Then
        WordDoc.SaveAs Filename:=rep.SelectedItems(1)
    Else
        WordDoc.Close SaveChanges:=False
        Wordapp.Quit
        Exit Sub
    End If
End Sub