XL 2013 Erreur en fin de boucle ?

Sub Recup_donnees_pour_TDB()

'Déclaration des variables
Dim nbr As Integer
Dim Derlig As Integer
Dim x As String
Dim y As Integer
Dim i As Integer
Dim Program As String
Dim PO As String
Dim PO_Date As String
Dim Content As String
Dim Deliv_Target_Date As String
Dim Deliv_Date_OTD1 As String
Dim Deliv_Time_OTD1 As String
Dim Last_Reject_Date As String
Dim Deliv_Date_OTD2 As String
Dim Deliv_Time_OTD2 As String
Dim Quality_OQD As String
Dim Quality_NC_Iteration As String
Dim Global_Quality As String
Dim Deliv_Note_Testia As String
Dim Deliv_Note_AIRBUS As String
Dim Good_Receipt As String
Dim Status As String
Dim Comments As String


'Exécution de la macro "Recuperation_Noms_sous_dossiers"
Call Recuperation_Noms_sous_dossiers

nbr = 0

'Recherche du numéro de la dernière ligne non vide en partant de B6 (dernier ID) --> derlig
'Recherche du nombre de références ID en colonne B --> nbr
Derlig = Application.WorksheetFunction.CountA(Range("B:B")) + 3
nbr = Range("B6:B" & Derlig).SpecialCells(xlCellTypeVisible).Count

'Affichage dans une boite de dialogue du nombre de références ID
MsgBox ("Vous avez " & nbr & " références d'ID")

'Initialisation des compteurs (on part de la ligne 6)
i = 0
y = 6

'Ouverture du fichier "FOLLOW_UP_TEST.xlsm" et activation de l'onglet "Feuil1"
'On l'ouvre avant la boucle pour éviter de l'ouvrir à chaque fois (messages systématiques)
'Workbooks.Open Filename:=Dossier_racine & "\" & "FOLLOW_UP_TEST.xlsm"
'Sheets("Feuil1").Activate

'MsgBox ("le fichier follow up Test doit être ouvert")

'Boucle sur le nombre de références ID, nbr (remplissage du tableau)
While i <= nbr

'Activation du fichier "FOLLOW_UP_TEST.xlsm", on active l'onglet "Feuil1"
Windows("FOLLOW_UP_TEST.xlsm").Activate
Sheets("Feuil1").Activate

'x correspond à la valeur de la cellule B6 (première valeur de la liste)
x = Range("B" & y).Value

'Ouverture du fichier "Entry_Form_ID.....xlsm" situé dans le dossier racine auquel on rajoute le sous-dossier ID....
'Activation de l'onglet "ADD_INFOS"
On Error GoTo fin
Workbooks.Open Filename:=Dossier_racine & "\" & x & "\" & "Entry_Form_" & x & ".xlsm"
Sheets("ADD_INFOS").Activate

'Mise en mémoire des données du fichier "Entry_Form_ID.....xlsm". Celles-ci sont à rapatrier dans le fichier "FOLLOW_UP_TEST.xlsm"
Program = Range("C7").Value
PO = Range("C8").Value
PO_Date = Range("C9").Value
Content = Range("C10").Value
Deliv_Target_Date = Range("H6").Value
Deliv_Date_OTD1 = Range("H8").Value
Deliv_Time_OTD1 = Range("H9").Value
Last_Reject_Date = Range("H11").Value
Deliv_Date_OTD2 = Range("H13").Value
Deliv_Time_OTD2 = Range("H14").Value
Quality_OQD = Range("M8").Value
Quality_NC_Iteration = Range("M10").Value
Global_Quality = Range("M12").Value
Deliv_Note_Testia = Range("F21").Value
Deliv_Note_AIRBUS = Range("F22").Value
Good_Receipt = Range("E30").Value
Status = Range("E31").Value
Comments = Range("E32").Value

'On active le fichier "FOLLOW_UP_TESTIA.xlsm" et on se mets dans l'onglet "Feuil1"
Windows("FOLLOW_UP_TESTIA.xlsm").Activate
Sheets("Feuil1").Activate

'On colle les valeurs précédemment mises en mémoire dans le fichier "FOLLOW_UP_TEST.xlsm" (onglet "Feuil1")
Range("C" & y).Value = Program
Range("D" & y).Value = PO
Range("E" & y).Value = PO_Date
Range("F" & y).Value = Content
Range("G" & y).Value = Deliv_Target_Date
Range("I" & y).Value = Deliv_Date_OTD1
Range("J" & y).Value = Deliv_Time_OTD1
Range("L" & y).Value = Quality_OQD
Range("M" & y).Value = Last_Reject_Date
Range("N" & y).Value = Deliv_Date_OTD2
Range("P" & y).Value = Deliv_Time_OTD2
Range("Q" & y).Value = Quality_NC_Iteration
Range("R" & y).Value = Deliv_Note_Testia
Range("S" & y).Value = Deliv_Note_AIRBUS
Range("T" & y).Value = Good_Receipt
Range("U" & y).Value = Status
Range("V" & y).Value = Comments
Range("W" & y).Value = Global_Quality

y = y + 1

'Fermer le fichier "Entry_Form_ID....xlsm" sans l'enregistrer (false)
Workbooks("Entry_Form_" & x & ".xlsm").Close False

Wend

fin:

End Sub