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