Excel se ferme quand j'execute ma macro

Bonjour a tous,

Gros soucis, j'avais une macro qui marchait tres bien (extract de donnees de plusieurs fichier dans un seul). Or, depuis quelques jours, Excel se faire a chaque fois que j'essaye d'executer ma macro ("Microsoft Excel has stopped working").
Je travaille sur Excel 2013 et ne trouve vraiment pas de solution a mon probleme.
Si vous en avez une n'hesitez pas a la partager !
Merci d'avance a mon/mes sauveurs.

Ci-dessous mon code (mais je ne pense pas que le probleme vienne de celui-ci)
Option Explicit
'Declaration des variables
Dim NomClasseur As String
Dim LigneTotal As Integer
Dim DerLigne As Integer
Dim Cell As Range
Dim Cellule As Range
Dim Ligne As Long




'Procedure permettant la consolidation de plusieurs classeurs

Sub Consolider()

'Etape 1 : creation des en-tetes

Columns("A:AG").Clear ' On reinitialise le fichier synthese
Range("B1").Value = "PORT PAIR"
Range("C1").Value = "KEY"
Range("D1").Value = "OPERATOR"
Range("E1").Value = "NO."
Range("F1").Value = "REGION"
Range("G1").Value = "POL"
Range("H1").Value = "TERMINAL POL"
Range("I1").Value = "POD"
Range("J1").Value = "TERMINAL POD"
Range("K1").Value = "WEEKLY VOL."
Range("L1").Value = "TRANSIT TIME"
Range("M1").Value = "FREQUENCY"
Range("N1").Value = "TERMS"
Range("O1").Value = "CURRENCY"
Range("P1").Value = "20'GP"
Range("Q1").Value = "40'GP & HC"
Range("R1").Value = "45'GP"
Range("S1").Value = "20'MT"
Range("T1").Value = "40'GP & HC"
Range("U1").Value = "45'MT"
Range("V1").Value = "20'RF Surcharge"
Range("W1").Value = "40'RF Surcharge"
Range("X1").Value = "45'RF Surcharge"
Range("Y1").Value = "20'IMCO Surcharge"
Range("Z1").Value = "20'IMCO REMARK"
Range("AA1").Value = "40'IMCO Surcharge"
Range("AB1").Value = "40'IMCO REMARK"
Range("AC1").Value = "45'IMCO Surcharge"
Range("AD1").Value = "45'IMCO REMARK"
Range("AE1").Value = "If Rates quoted in FI/FO terms, please state the Stevedoring / CY revovery rates at POL or POD (e.g. SIN CY laden - SGD115/175/190 per 20'/40'/45')"
Range("AF1").Value = "REMARKS"
Range("B1:AF1").Interior.Color = vbYellow 'Couleur de remplissage
Range("B1:AF1").Font.Bold = True 'Mise en gras des caracteres

'Etape 2 : Parcourir tous les fichiers du dossier predefinis

ChDir "C:\Users\sgp.lmhbayle\Desktop\1st Submission"
'On cherche le premier classeur dans le dossier
NomClasseur = Dir("C:\Users\sgp.lmhbayle\Desktop\1st Submission\*xlsx")
'On boucle pour chercher tous les classeurs Excel
While Len(NomClasseur) > 0
Application.DisplayAlerts = False 'Desactive les boite de dialogue d'Excel
Workbooks.Open NomClasseur 'Ouverture du classeur
LigneTotal = ActiveSheet.UsedRange.Rows.Count 'On recupere le nombre de ligne de donnees
Range("B3:AF" & LigneTotal).Copy 'On copie toutes les donnees de la feuille active
Workbooks("2019 Q3 Consolidate").Activate 'On revient sur le classeur de synthese
DerLigne = ActiveSheet.UsedRange.Rows.Count + 1 'On recherche la derniere ligne vide de la feuille active
Range("E" & DerLigne).Select 'On se positionne sur la derniere ligne vide de la feuille
ActiveSheet.Paste 'Je colle les donnees
Range("D" & DerLigne & ":D" & ActiveSheet.UsedRange.Rows.Count) = NomClasseur 'On colle le nom du classeur sur la colonne D
Workbooks(NomClasseur).Close 'Fermeture du classeur ouvert
NomClasseur = Dir 'On passe au prochain classeur
Wend

'Etape 3 : Suppression des extensions des fichiers

Columns("D:D").Replace ".xlsx", "" 'On retire l'extension des fichiers

On Error Resume Next
Ligne = Columns("D").Find("*", , , , , xlPrevious).Row
Range("N2:N" & Ligne).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Range("A2:DerLigne").Interior.Color = vbWhite 'Couleur de remplissage
Range("A2:DerLigne").Font.Color = vbBlack 'Couleur de police

Columns("A:AG").Select
Selection.ColumnWidth = 15
Selection.RowWidth = 10
Selection.Borders.LineStyle = xlNone
Selection.Font.Name = "Calibri"
Selection.Font.Size = 11
Selection.Interior.Color = vbWhite

Range("B1:AF1").Interior.Color = vbYellow 'Couleur de remplissage

Application.Goto Range("A1"), True

Dim i As Long
For i = 2 To DerLigne
Range("B" & i).Value = Range("G" & i).Value & "-" & Range("I" & i).Value
Next i

For i = 2 To DerLigne
Range("C" & i).Value = Range("G" & i).Value & "-" & Range("I" & i).Value & "-" & Range("D" & i).Value
Next i

End Sub