Excel se ferme quand j'execute ma macro
Lbrochette
Messages postés
9
Statut
Membre
-
f894009 Messages postés 17413 Statut Membre -
f894009 Messages postés 17413 Statut Membre -
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
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
A voir également:
- Fichier excel qui se ferme tout seul
- Fichier bin - Guide
- Fichier epub - Guide
- Fichier rar - Guide
- Comment réduire la taille d'un fichier - Guide
- Application se ferme toute seule android - Guide