Probleme de suppression de ligne

Re bonjour,
j'ai progressé dans mon code et cela fonctionne.
mais je valide une ligne supplémentaire cela efface les renvois de cellule de la ligne au dessus
avez vous un conseil sur mon code ?
merci d'avance
code ci-dessous
titi
Sub Macro9()
Dim maLigne As Long
With Sheets("Fiche a completer CSV 20,20")
If .Range("F3") <> "" Then
maLigne = .Range("F" & Rows.Count).End(xlUp).Row + 1
Else
maLigne = 1
End If
Range("A2:D2").Select
Selection.Copy
Range("F" & maLigne).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With renvoie
Dim Ws As Worksheet, Trouve As Range, Ligne As Long, Depart As String, Ok As Boolean

Application.ScreenUpdating = False
On Error Resume Next
Range("A4:E300").SpecialCells(xlCellTypeConstants, 23).ClearContents
On Error GoTo 0
If Range("A2") = "" Then Exit Sub

Ligne = maLigne
For Each Ws In Worksheets
Set Trouve = Ws.Columns("B").Find(Range("A2"), LookIn:=xlValues, LookAt:=xlWhole)
If Not Trouve Is Nothing Then
Depart = Trouve.Address
Do
Ok = True
Range("A" & Ligne) = Trouve.Offset(0, -1)
Range("c" & Ligne) = Trouve.Offset(0, 2)
Range("B" & Ligne) = Trouve.Offset(0, 1)
Range("D" & Ligne) = Trouve.Offset(0, 3)
Ligne = Ligne + 1
Set Trouve = Ws.Columns("B").FindNext(Trouve)
Loop While Trouve.Address <> Depart
End If
Next Ws
If Ok = False Then
End If
End With
End With
End Sub