Problème Excel et Vb6-Excel reste en mémoire

Bonjour,
Je rencontre actuellement un probleme sur un .EXE avec référencement excel.
La form ouvre deux fichiers successivement, le premier s'ouvre et mes zone de texte s'alimente sans probleme et le fichier excel se referme correctement(même en mémoire), le deuxieme fichier excel s'ouvre mais ne se referme pas à la fin du traitement, du coup, quand je relance le traitement ca me fait une erreur "le serveur distant n'existe pas ou n'est pas disponible" sur la ligne :

Code:

1
2
Selection.Subtotal GroupBy:=5, Function:=xlSum, TotalList:=Array(3, 5), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True

Même quand je ferme excel en dur dans le gestionnaire de tache ne résoud pas le probleme.
Auriez vous des pistes ?
Merci.

Le code complet :

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
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
123
124
125
126
127
128
129
130
131
132
133
Private Sub Command6_Click() 'rapatrier soldes newedge
Dim appExcel As Excel.Application 'Application Excel
Dim wbExcel As Workbook 'Classeur Excel
Dim wsExcel As Worksheet 'Feuille Excel
 
'Ouverture de l'application
Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = True
'Ouverture d'un fichier Excel
Set wbExcel = appExcel.Workbooks.Open("C:\Users\H\Documents\Appel marge Tawfik\Etat newedge.xls")
'wsExcel correspond à la première feuille du fichier
Set wsExcel = wbExcel.ActiveSheet
'''''''''''''''''
'''''''''''''''''
With ActiveSheet
Sheets("Récap positions Newedge").Select
 
Dim i As Long
Dim J As Long
Dim montableau(5000, 4) As Variant
'Dim Rg As wbExcel.Range
Dim Plage As String
Dim myrange As String
Dim myrange1 As String
Plage = "D1:D5000"
 
'Désactive la mise à jour de l'affichage
'Application.ScreenUpdating = False
'Désactive la mise à jour des recalculs
'appExcel.Application.Calculation = xlCalculationManual
With Form1.Text14
'Set Rg = Range(plage).Find(Text14)
i = 2
J = 0
     myrange = Sheets("Récap positions Newedge").Range("D" & i).Value
     myrange1 = Sheets("Récap positions Newedge").Range("G" & i).Value
While myrange <> ""
     myrange = Sheets("Récap positions Newedge").Range("D" & i).Value
     myrange1 = Sheets("Récap positions Newedge").Range("G" & i).Value
 
      If myrange = Text14 And myrange1 = "F" Then
        montableau(J, 0) = Sheets("Récap positions Newedge").Range("D" & i).Value 'code newedge
        montableau(J, 1) = Sheets("Récap positions Newedge").Range("L" & i).Value 'qté futures
        montableau(J, 2) = Sheets("Récap positions Newedge").Range("N" & i).Value 'VB
        montableau(J, 3) = Sheets("Récap positions Newedge").Range("T" & i).Value 'Cours j
        montableau(J, 4) = Sheets("Récap positions Newedge").Range("U" & i).Value 'Devise
End If
i = i + 1
J = J + 1
Wend
End With
''''''''''''''''''''''
'vérif existance feuille
With Text14
'Dim sh As Worksheet
 ' For Each sh In Worksheets
'If sh.Name = Text14 Then
'  sh.Select
'End If
'Next
  ' wbExcel.sh.Add
   'ActiveSheet.Name = Range("A2").Value
  ' End With
 
   Dim AN As Byte
For AN = 1 To Sheets.Count
If Sheets(AN).Name = Text14 Then
Sheets(AN).Select
Exit For
End If
Next AN
 
If ActiveSheet.Name = Text14 Then
ActiveSheet.Select
Else
Sheets.Add.Name = Text14
End If
End With
''''''''''''''''''''''
 'active la feuil1 pour y mettre Montableau
   Set wsExcel = ActiveSheet
Derligne = J - 1
For i = 0 To Derligne 'UBound(Montableau, 2)
     For J = 0 To UBound(montableau, 2) 'UBound(Montableau, 1) il fallait mettre 2 au lieu de 1 car
        ActiveSheet.Cells(i + 3, J + 1) = montableau(i, J)
    Next J
Next i
 
    ActiveSheet.Range("A1") = "Code newedge"
    ActiveSheet.Range("B1") = "Qté Futures"
    ActiveSheet.Range("C1") = "VB"
    ActiveSheet.Range("D1") = "Cours j"
    ActiveSheet.Range("E1") = "Devise"
 
 Erase montableau
 
'   On Error Resume Next
     'supprime les lignes vides
 
 ActiveSheet.Range("A2:A" & Range("A65226").End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
 
    'mettre sous totaux
        Selection.Subtotal GroupBy:=5, Function:=xlSum, TotalList:=Array(3, 5), _
        Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    Cells.Select
    Cells.EntireColumn.AutoFit
  '''''''''''''''''''''''''''''''''''
  Dim Y As Long
  Dim myrange2 As String
'boucler sur listbox
 With Form1.Label10
    Y = 2
    myrange2 = Range("D" & Y).Value
    While myrange2 <> ""
    myrange2 = Range("D" & Y).Value
    If Right(Range("D" & Y).Value, 3) = Label10.Caption Then
Form1.Text1 = Range("D" & Y).Offset(0, -1).Value
End If
Y = Y + 1
Wend
End With
End With
 
wbExcel.Save
wbExcel.Close
appExcel.Quit
 
Set wsExcel = Nothing
Set wbExcel = Nothing
Set appExcel = Nothing
 
End Sub

Par avance Merci