Bonjour,
J'ai un fichier avec beaucoup de macro et notamment un feuille qui peut être copier, mon problème c'est qu'après plusieurs copie (environ à la 5ème) la macro plante et les boutons macro perdent toutes les liaisons!!!
Si j'enregistre et ré ouvre le fichier avant qu'il plante cela me permet de copier plus de feuilles mais finira aussi par planté! Est-ce un problème mémoire?
Voici mon code (assez complexe, enfin pour moi en tout cas) ?
J'ai un fichier avec beaucoup de macro et notamment un feuille qui peut être copier, mon problème c'est qu'après plusieurs copie (environ à la 5ème) la macro plante et les boutons macro perdent toutes les liaisons!!!
Si j'enregistre et ré ouvre le fichier avant qu'il plante cela me permet de copier plus de feuilles mais finira aussi par planté! Est-ce un problème mémoire?
Voici mon code (assez complexe, enfin pour moi en tout cas) ?
Code:
Sub copie_contact()
'Ne pas lancer la macro si la cellule avec le N°P n'est pas entrée
If Range("Y1") = "" Then
MsgBox "cliquer d'abord sur: Données d'entrées, et attribuer un numéro P "
Exit Sub
End If
Application.EnableEvents = False
Dim MonMessage As String
Dim Rep As Byte
'Ouvre une messageBox :
MonMessage = "Copie:" & vbLf & vbLf & "Garder les donneés introduites?"
Rep = MsgBoxPerso(MonMessage, "mDF XLpages.com", vbQuestion, "Garder données", "Feuille vierge", True)
Select Case Rep
'/////////////////// Si réponse = Garder données /////////////////////////////////////////////////////////////////
Case 1
Dim w As String
Dim h As Byte
w = ActiveSheet.Name
FeuilleOrigine = w
FeuilleDestination = w
PremierNumero = 1
formats = "0"
NumeroSuivant = Format(PremierNumero, formats)
CopierApres = Sheets.Count - 6
'Copier:
For Each ws In Application.Worksheets
nbr = nbr + 1
If UCase(Left(ws.Name, Len(FeuilleDestination))) = UCase(FeuilleDestination) Then
If Len(Mid(ws.Name, Len(FeuilleDestination) + 1)) = Len(NumeroSuivant) Then
num = Val(Mid(ws.Name, Len(FeuilleDestination) + 1))
If num >= Val(NumeroSuivant) Then
NumeroSuivant = Format(Val(num) + 1, formats)
CopierApres = nbr
End If
End If
End If
Next
Sheets(FeuilleOrigine).Copy After:=Sheets(CopierApres)
ActiveSheet.Name = FeuilleDestination & NumeroSuivant
'Outillage : Effacer toutes les cases colorées en vert foncé
Range("Cellules_sup_outillage_coloré").Select 'plage défini dans gestionnaire de nom
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Mettre la version à 0
Range("BA862").Select
ActiveCell.FormulaR1C1 = "0"
'Incrémenter la numerotation d'une cellule
For h = 1 To Worksheets.Count
Worksheets(h).Range("BG911").Value = h
Next h
'lancer formulaire pour renomer la pièce
UserForm2.Show 'Voir le code sous userform2 -->code
' Mettre le nom de la pièce à l'onglet
ActiveSheet.Name = ActiveSheet.Range("I1")
'<<<<<<<<<<<<<<<<<<<<<<<<< Mettre les noms des feuilles à jour : >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Afficher la liste des noms (codename) de toutes les feuillee
Dim Manquant As String ' variable pour nom de la feuille si nombre manquant (dans l'incementation)
Range("BV39").Select
For r = 1 To Sheets.Count
ActiveCell.Value = Sheets(r).CodeName
ActiveCell.Offset(1, 0).Select
Next r
'Recherche des numero de feuille manquant
Dim N As Long, i As Long, j As Long
With ActiveSheet
N = Application.Max(.Range("BX39:BX66"))
j = 1
For i = 1 To N - 1
If Application.CountIf(.Range("BX39:BX66"), i) = 0 Then
j = j + 37
.Cells(j, 76) = i
End If
Next i
End With
'Modifier nom (code) de la feuille si feuille manquant
Manquant = "Feuil" & ActiveSheet.Range("BX38")
If Range("BX38") = "" Then
'Rien
Else
With ActiveSheet
.Parent.VBProject.VBComponents(.CodeName).Properties("_CodeName") = Manquant
End With
End If
'Activer le défilement (limiter en horizontal)
ActiveSheet.ScrollArea = "A1:BE1100"
ActiveWindow.SmallScroll Down:=-900
Range("C1").Select
'/////////////////// Si réponse = Feuille vierge /////////////////////////////////////////////////////////////////
Case 2
w = ActiveSheet.Name
FeuilleOrigine = w
FeuilleDestination = w
PremierNumero = 1
formats = "0"
NumeroSuivant = Format(PremierNumero, formats)
CopierApres = Sheets.Count - 6
'Copier:
For Each ws In Application.Worksheets
nbr = nbr + 1
If UCase(Left(ws.Name, Len(FeuilleDestination))) = UCase(FeuilleDestination) Then
If Len(Mid(ws.Name, Len(FeuilleDestination) + 1)) = Len(NumeroSuivant) Then
num = Val(Mid(ws.Name, Len(FeuilleDestination) + 1))
If num >= Val(NumeroSuivant) Then
NumeroSuivant = Format(Val(num) + 1, formats)
CopierApres = nbr
End If
End If
End If
Next
Sheets(FeuilleOrigine).Copy After:=Sheets(1)
ActiveSheet.Name = FeuilleDestination & NumeroSuivant
'Effacer toutes les cases contenant une donnée entrée manuellement
Range("Cellules_supp_cts").Select 'plage défini dans gestionnaire de nom
Selection.ClearContents
'Outillage : Effacer toutes les cases contenant une donnée entrée manuellement
Range("Cellules_sup_outillage").Select 'plage défini dans gestionnaire de nom
Selection.ClearContents
'Outillage : Effacer toutes les cases colorées en vert foncé
Range("Cellules_sup_outillage_coloré").Select 'plage défini dans gestionnaire de nom
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Décoche les cases à cocher
ActiveSheet.Shapes.Range(Array("Groupe outillage")).Select
Selection.ShapeRange.Ungroup.Select
With Selection
.Value = 0
.LinkedCell = ""
.Display3DShading = False
End With
Selection.ShapeRange.Regroup.Select
Selection.Name = "Groupe outillage"
'Mettre la version à 0
Range("BA856").Select
ActiveCell.FormulaR1C1 = "0"
'Incrémenter la numerotation d'une cellule
For h = 1 To Worksheets.Count
Worksheets(h).Range("BG911").Value = h
Next h
'lancer formulaire pour renomer la pièce
UserForm2.Show 'Voir le code sous userform2 -->code
' Mettre le nom de la pièce à l'onglet
ActiveSheet.Name = ActiveSheet.Range("I1")
'<<<<<<<<<<<<<<<<<<<<<<<<< Mettre les noms des feuilles à jour : >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'Afficher la liste des noms (codename) de toutes les feuillee
Range("BV39").Select
For r = 1 To Sheets.Count
ActiveCell.Value = Sheets(r).CodeName
ActiveCell.Offset(1, 0).Select
Next r
'Recherche des numero de feuille manquant
With ActiveSheet
N = Application.Max(.Range("BX39:BX66"))
j = 1
For i = 1 To N - 1
If Application.CountIf(.Range("BX39:BX66"), i) = 0 Then
j = j + 37
.Cells(j, 76) = i
End If
Next i
End With
'Modifier nom (code) de la feuille si feuille manquant
Manquant = "Feuil" & ActiveSheet.Range("BX38")
If Range("BX38") = "" Then
'Rien
Else
With ActiveSheet
.Parent.VBProject.VBComponents(.CodeName).Properties("_CodeName") = Manquant
End With
End If
'Activer le défilement (limiter en horizontal)
ActiveSheet.ScrollArea = "A1:BE1100"
ActiveWindow.SmallScroll Down:=-900
Range("C1").Select
'/////////////////// Si réponse Annuler : /////////////////////////////////////////////////////////////////
Case 0
Range("I1").Select
End Select
Application.EnableEvents = True
End Sub
