VBA Macro pour effacer le contenu et affecter le couleur

Bonjour,

Est-ce que quelqu'un pourrait m'aider avec la tâche suivante, s'il-vous-plaît?

Je souhaiterais avoir un macro qui effacerait le contenu et affecterait le même couleur sur les cases supplémentaires en fonction de la case référente.

Ci-jointe un exemple: La case référente est "Créneau principal Téléphonie".

Les cases supplémentaires sont "Créneau supp Téléphonie", "Créneau principal Mail".

L'objectif c'est d'effacer le contenu des cases "Créneau supp Téléphonie", "Créneau principal Mail", si la case "Créneau principal Téléphonie" est coloré (peu importe si elle comporte des valeurs ou pas).

Puis affecter aux cases "Créneau supp Téléphonie", "Créneau principal Mail" le même couleur que la case référente.

Merci par avance pour votre aide.

Bonjour

Un essai à tester. Te convient-il ?.

Option Explicit

Dim tablo
Dim i&, j&

Sub EffacerErColorer()

    tablo = Range("A1").CurrentRegion
    For i = 3 To UBound(tablo, 1) - 2 Step 3
        For j = 5 To UBound(tablo, 2)
            If Cells(i, j).Interior.color <> 16777215 Then
                Range(Cells(i + 1, j), Cells(i + 2, j)).Interior.color = Cells(i, j).Interior.color
                Range(Cells(i + 1, j), Cells(i + 2, j)).ClearContents
            End If
        Next j
    Next i
End Sub

Bye !

GMB bonjour,

C'est vraiment super et cela correspond à mes attentes à 100%

Merci beaucoup!!!

Une question, si vous me permettez, j'ai déjà un code qui est en place. Je souhaiterais que votre macro soit déclenché après que le macro existant aurait terminé de tourner. Est-ce que vous pouvez me guider, comment l'intégrer?

Merci beaucoup

Ci-dessous le code existant dont je parle:

Sub recopie_cellule(ligne_source As Integer, col_source As Integer, ligne_but As Integer, col_but As Integer)
'
' recopie_cellule Macro
'

'
Sheets("Abscences").Select
Cells(ligne_source, col_source).Select
Selection.Copy
Sheets("Planning").Select
Cells(ligne_but, col_but).Select
ActiveSheet.Paste
End Sub

Public Function cherche_ligne_du_nom(nom As String) As Integer
Dim ligne As Integer
ligne = 3
While planning.Cells(ligne, 2) <> nom And planning.Cells(ligne, 2) <> ""
ligne = ligne + 1
Wend
If planning.Cells(ligne, 2) = "" Then
MsgBox "ce nom n'existe pas dans la feuille planning"
End If
cherche_ligne_du_nom = ligne
End Function

Public Function recherche_colonne_de_date(jour As Date) As Integer
Dim colonne As Integer
colonne = 5
'format(MyDate,"dd/mm/yyyy")
ma_date = planning.Cells(2, 5)
While ma_date <> jour And ma_date <> ""
colonne = colonne + 1
ma_date = planning.Cells(2, colonne)

Wend

recherche_colonne_de_date = colonne

End Function

Public Function recherche_couleur_cellule(ligne As Integer, col As Integer) As Boolean
If absence.Cells(ligne, col).Interior.Color <> 16777215 Then
recherche_couleur_cellule = True
Else
recherche_couleur_cellule = False
End If
End Function

Public Sub test()
x = recherche_couleur_cellule(3, 2)
End Sub

Public Sub recopie_absence()
Dim ligne As Integer
Dim col As Integer
Dim ligne_planning As Integer
Dim col_planning As Integer
col = 2
ligne = 2
nb_col_planning = planning.Cells(1, Columns.Count).End(xlToLeft).Column
While absence.Cells(1, col) <> ""

While absence.Cells(ligne, 1) <> ""
If recherche_couleur_cellule(ligne, col) Then
ligne_planning = cherche_ligne_du_nom(absence.Cells(ligne, 1))
col_planning = recherche_colonne_de_date(absence.Cells(1, col))
If col_planning <= nb_col_planning Then
Call recopie_cellule(ligne, col, ligne_planning, col_planning)
End If
'MsgBox "recopie ligne " & ligne & "col " & col
End If
ligne = ligne + 1
Wend
col = col + 1
ligne = 2
Wend



End Sub

Option Explicit

Dim tablo
Dim i&, j&

Je souhaiterais que votre macro soit déclenché après que le macro existant aurait terminé de tourner.

Sub recopie_cellule(ligne_source As Integer, col_source As Integer, ligne_but As Integer, col_but As Integer)
    '...
    '...
    Call EffacerErColorer
End Sub

Bye !

Merci beaucoup!