Re : Copier Coller Cellule avec Validation en conservant la couleur
Bonjour le Forum
Merci Speel mais j'ai adapté la macro différement
Par contre dès que je copie sur les deux premières colonnes nickel mais dès que je passe aux suivvant j'ai le sablier et cela fat planter Excel.
Avez vous une idée ?
Merci
ci-dessous ma macro
Private Sub Worksheet_Change(ByVal Target As Range)
Dim temoin As Boolean
Dim Ref As Variant
If Not Intersect(Target, Range("g8:ep735")) 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:ad1").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:ad2").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
End Sub