transfert cellules lignes avec condition puis suppression ligne

Sub Transfert_suppression_Tiers()

Dim bd As Object
Dim i As Integer, a As Integer
Dim lig As Integer
Dim pl As Range, cell As Range
Dim Nposte As String, Obs As String
Dim dl As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.ScreenUpdating = False

Set bd = Sheets("Consult") 'définit l'onglet bd
dl = bd.Cells(Application.Rows.Count, 1).End(xlUp).Row
Set pl = bd.Range("B8:B" & dl) 'définit la plage 

'Transfert données "Tiers"  en observation et suppression lignes contenant "tiers"

Bsuivant:
    With pl
        Set n = .Find(what:="Tiers", LookIn:=xlValues, LookAt:=xlWhole)
   End With
    If Not n Is Nothing Then
        lig = n.Row
 
    Nposte = Cells(lig, 4)
    Obs = Cells(lig, 10) & Chr(10) & Cells(lig, 13)
    
    
    bd.Range("A:D").AutoFilter 4, Nposte
  
Set Plage = pl.SpecialCells(xlCellTypeVisible)
    For Each cell In Plage
    a = cell.Row
        If UCase(cell) = "G" And Cells(a, 3) = "G1" Then
        bd.Cells(a, 13) = Cells(a, 13) & Chr(10) & Obs
        bd.Cells(lig, 1).EntireRow.Delete
        End If
        
        If UCase(cell) = "O" And Cells(a, 3) = "O1" Then
        bd.Cells(cell.Row, 13) = Cells(a, 13) & Chr(10) & Obs
        bd.Cells(lig, 1).EntireRow.Delete
        End If
    
    Next cell
 
Set Plage = Nothing
bd.Cells.AutoFilter
GoTo Bsuivant
 
    Else: Exit Sub
    End If

End Sub