La cellule doit rester blanche en tirant vers le bas

Sub Blanc()
For i = 2 To 40 ' a changer selon le nombre de ligne dans ton tableau
Set c = Range("B" & i)
If c.MergeCells = False And Range("A" & i) <> "" Then ' si on a une cellule non fusionnée et la cellule de coté (en A) alors la couleur de Fond change en jaune. 
Range("B" & i).Select
    With Selection.Interior
        .Color = 65535
    End With
End If
Next
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range, fusion As Range
If Target.Address = "$B$2" Then
  Set r = Intersect([B:B], Me.UsedRange)
  If r Is Nothing Then Exit Sub 'sécurité
  For Each r In r
    Set r = r.MergeArea
    If r.Count > 1 Then _
      Set fusion = Union(r, IIf(fusion Is Nothing, r, fusion))
  Next
  If fusion Is Nothing Then Exit Sub
  fusion.Name = "ZoneFusion" 'nom défini pour mémoriser
  fusion.UnMerge
  fusion.HorizontalAlignment = xlCenterAcrossSelection
ElseIf Not IsError([ZoneFusion]) Then
  [ZoneFusion].Merge
  ThisWorkbook.Names("ZoneFusion").Delete
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim r As Range, n&, nom As Name
If Target.Address = "$B$2" Then
  Set r = Intersect([B:B], Me.UsedRange)
  If r Is Nothing Then Exit Sub 'sécurité
  For Each r In r
    Set r = r.MergeArea
    If r.Count > 1 Then
      n = n + 1
      r.Name = "ZoneFusion" & n 'nom défini pour mémoriser
      r.UnMerge
      r.HorizontalAlignment = xlCenterAcrossSelection
    End If
  Next
Else
  For Each nom In ThisWorkbook.Names
    If nom.Name Like "ZoneFusion*" Then
      Evaluate(nom.Name).Merge
      nom.Delete
    End If
  Next
End If
End Sub

If Target.Count = 1 Then Target.MergeArea.Select