Lenteur Macro

[dirmon]

Bonjour le Forum

Lorsque, je fais un copier coller de plusieurs cellule sur la même feuille le temps de réponse de la macro est extrêmement long.

Pouvez vous m'aider ?

Merci

la macro :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim temoin As Boolean
Dim Ref As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Not Intersect(Target, Range("g8:eq735")) Is Nothing And Target.Count = 1 And Not temoin Then 'test1
temoin = True
Target.Interior.ColorIndex = xlNone
For Each Ref In Sheets("MFC").Range("CouleurMFC1")
If UCase(Target.Value) = UCase(Ref.Value) Then 'test2

With Target
.RowHeight = Ref.RowHeight 'hauteur de ligne
.ColumnWidth = Ref.ColumnWidth 'largeur de colonne
.NumberFormat = Ref.NumberFormat 'format de nombre

.HorizontalAlignment = Ref.HorizontalAlignment 'alignement horizontal
.VerticalAlignment = Ref.VerticalAlignment 'alignement vertical
.WrapText = Ref.WrapText 'Retour à la ligne
.Orientation = Ref.Orientation 'Orientation du texte
.AddIndent = Ref.AddIndent 'Retrait
.IndentLevel = Ref.IndentLevel 'Niveau de retrait
.ShrinkToFit = Ref.ShrinkToFit 'Ajustement à la largeur de la cellule
.ReadingOrder = Ref.ReadingOrder 'sens de lecture
.MergeCells = Ref.MergeCells 'Cellules fusionnées

.Borders(xlDiagonalDown).LineStyle = Ref.Borders(xlDiagonalDown).LineStyle
.Borders(xlDiagonalUp).LineStyle = Ref.Borders(xlDiagonalUp).LineStyle
.Borders(xlEdgeLeft).LineStyle = Ref.Borders(xlEdgeLeft).LineStyle
.Borders(xlEdgeTop).LineStyle = Ref.Borders(xlEdgeTop).LineStyle
.Borders(xlEdgeBottom).LineStyle = Ref.Borders(xlEdgeBottom).LineStyle
.Borders(xlEdgeRight).LineStyle = Ref.Borders(xlEdgeRight).LineStyle
.Borders(xlInsideVertical).LineStyle = Ref.Borders(xlInsideVertical).LineStyle
.Borders(xlInsideHorizontal).LineStyle = Ref.Borders(xlInsideHorizontal).LineStyle

.Interior.ColorIndex = Ref.Interior.ColorIndex

With .Font
.Name = Ref.Font.Name 'police
.Size = Ref.Font.Size 'taille

.ColorIndex = Ref.Font.ColorIndex 'couleur de police
.Bold = Ref.Font.Bold 'gras ou non
.Italic = Ref.Font.Italic 'italique ou non
.Underline = Ref.Font.Underline 'souligné ou non
'.FontStyle = Ref.FontStyle
'.Strikethrough = Ref.Strikethrough
'.Superscript = Ref.Superscript
'.Subscript = Ref.Subscript
'.OutlineFont = Ref.OutlineFont
'.Shadow = Ref.Shadow
End With 'font

End With 'target
End If 'test2
Next Ref
temoin = False
End If 'test1
If Target.Address = "$A$1" Then
Set MaSélection = Nothing
Range("IV:IV").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 256).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 256)
Else
Set MaSélection = Union(MaSélection, Cells(i, 256))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$2" Then
Set MaSélection = Nothing
Range("IT:IT").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 254).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 254)
Else
Set MaSélection = Union(MaSélection, Cells(i, 254))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$3" Then
Set MaSélection = Nothing
Range("IV:IV").EntireRow.Hidden = False
If Target.Value <> "" Then
For i = 8 To 962
If Cells(i, 256).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(i, 256)
Else
Set MaSélection = Union(MaSélection, Cells(i, 256))
End If
End If
Next i
MaSélection.EntireRow.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$4" Then
Set MaSélection = Nothing
Range("G1:bt1").EntireColumn.Hidden = False
If Target.Value <> "" Then
For i = 4 To 147
If Cells(1, i).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(1, i)
Else
Set MaSélection = Union(MaSélection, Cells(1, i))
End If
End If
Next i
MaSélection.EntireColumn.Hidden = True
Set MaSélection = Nothing
End If
End If
If Target.Address = "$A$5" Then
Set MaSélection = Nothing
Range("G2:bt2").EntireColumn.Hidden = False
If Target.Value <> "" Then
For i = 4 To 147
If Cells(2, i).Value <> UCase(Target.Value) Then
If MaSélection Is Nothing Then
Set MaSélection = Cells(2, i)
Else
Set MaSélection = Union(MaSélection, Cells(2, i))
End If
End If
Next i
MaSélection.EntireColumn.Hidden = True
Set MaSélection = Nothing
End If
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

 

[TooFatBoy]

Bonjour,

Tu parles de copier/coller de cellules, mais je n'en vois pas dans ta macro.
Remarque, il faut dire que telle qu'elle est postée c'est assez illisible... 🙁

Tu peux au moins utiliser la balise "Code" avec la valeur "VB" pour que ce soit un peu moins imbuvable.
Mais le mieux, voire l'indispensable, c'est de joindre un fichier "dépersonnalisé". 😉

 

[dirmon]

Bonjour

Merci Marcel de m'avoir répondu

Je joins donc le fichier

Le problème se situe sur l'onglet "Planning Général"

Quand je copie par exemple les celules G8:H735 à partir de la cellule J8 le programme plante avec semble t il la macro qui tourne en boucle.

Si qqn peut m'aider merci par avance

http://www.cjoint.com/c/GDudcHHZxPh

​

 

[dirmon]

Bonjour le forum

Si qqn peut m aider ?

Merci

 

[PMO2]

Bonjour,
Il faut peut être désactiver les événements avant de faire un copier/coller ???
Essayez avec le code suivant à copier dans un module Standard

Sub aa()
Application.EnableEvents = Not Application.EnableEvents
If Application.EnableEvents Then
  MsgBox "Evénements activés"
Else
  MsgBox "Evénements désactivés"
End If
End Sub

 

[dirmon]

Bonsoir

La proposition de PMO2 me semble intéressante mais m'oblige à chaque fois de penser à désactiver via un bouton.

Qqn peut il m'aider d'une autre façon ?

Merci

 

[dirmon]

Bonsoir

Apres test cela ne marche pas.

Pas contre il semble que qd le fichier est avec l'extension Xlsm cela ne fonctionne pas contrairement au format Xlk

Coïncidence ?

Merci pour votre aide