Aide VBA Excel : Inserer des lignes sous condition

Option Explicit

Sub LancementListing1()

Dim Lastli As Integer, rCell As Range

Lastli = Sheets("Fiche").Cells(1, 19).End(xlDown).Row

'Fige l'écran pendant la suppression des lignes
Application.ScreenUpdating = False

For Each rCell In Sheets("Fiche").Range("U1:U" & Lastli)
    'Si valeur cellule égale B6 de Feuil9
    If rCell = ActiveSheet.Range("B6") Then
        'Alors insérer une ligne en ligne 12 (par exemple)
        With ActiveSheet
            .Rows("12:12").Insert Shift:=xlDown
            'Copy les données de la colonne S Feuil2 correspondantes
            With .Cells(12, 1)
              .Value = Sheets("Fiche").Cells(rCell.Row, 19).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 2)
              .Value = Sheets("Fiche").Cells(rCell.Row, 6).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 3)
              .Value = Sheets("Fiche").Cells(rCell.Row, 5).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 5)
              .Value = Sheets("Fiche").Cells(rCell.Row, 12).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 6)
              .Value = Sheets("Fiche").Cells(rCell.Row, 13).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
            With .Cells(12, 7)
              .Value = Sheets("Fiche").Cells(rCell.Row, 14).Value
              .Interior.ColorIndex = 15       'on grise la cellule matchée
            End With
            
        End With
    End If
Next rCell
Call SupDoublons
Application.ScreenUpdating = True
End Sub


Sub SupDoublons()
    
    Dim Plage As Range, Cell As Range
    Dim Un As New Collection
    Dim Tableau() As Integer
    Dim x As Integer
 
    'Définit la plage de cellules pour la recherche de doublons
    Set Plage = ActiveSheet.Range("A10:A500")
 
    On Error Resume Next
    'Boucle sur les cellules de la plage cible
    For Each Cell In Plage
        'Création d'une collection de données uniques (sans doublons)
        Un.Add Cell, CStr(Cell)
 
        'Une erreur survient si l'élément existe dans la collection.
        'La procédure enregistre le numéro de ligne correspondant dans un tableau.
        If Err.Number <> 0 Then
            x = x + 1
            ReDim Preserve Tableau(1 To x)
            Tableau(x) = Cell.Row
            Err.Clear
        End If
    Next Cell
    On Error GoTo 0
 
    'On sort si aucun doublon n'a été trouvé.
    If x = 0 Then Exit Sub
 
     'Boucle sur le tableau pour supprimer les lignes contenant des doublons.
    For x = UBound(Tableau) To LBound(Tableau) Step -1
        ActiveSheet.Rows(Tableau(x)).EntireRow.Delete
    Next x
 
End Sub