Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2013 Perte des liens macro après plusieurs copies de la feuille

fred2705

XLDnaute Junior
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) ?

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
 

Discussions similaires

Réponses
7
Affichages
528
Réponses
0
Affichages
352
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…