Rectificatif de la macro ajout feuille

[MAN]

Bonjour le forum : bonjour à tous.
Voilà mon fichier. La macro jointe COPIER FEUILLE. Fonctionne bien. Merci le forum. Cependant, j’aurai voulu que la copie simple soit faite pour les cellules non liées aux cellules antérieures. Ce qui n’est pas le cas actuellement. Quelques autres détails sont sur le fichier lui-même.
Toutes les cellules blanches doivent être vides dans la nouvelle feuille.
Les autres données doivent être maintenues.
Merci d’avance de votre aide.
J’oubliais : je joins la macro.
Sub Ajout_Feuille()
Dim Sh As Worksheet, Trouve As Range
Dim Expression As String, Remplace As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With ThisWorkbook
Set Sh = .Worksheets(.Worksheets.Count)
Sh.Copy After:=.Worksheets(.Worksheets.Count)

With .ActiveSheet
.Name = CLng(Sh.Name) + 1
With .UsedRange
Expression = "'" & Sh.Previous.Name & "'"
Set Trouve = .Find(What:=Expression, _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)

If Not Trouve Is Nothing Then
Do
X = Trouve.Formula
Remplace = "'" & Sh.Name & "'"
Y = Application.Substitute(X, Expression, Remplace)
Trouve.Formula = Y
Set Trouve = .FindNext(Trouve)
Loop Until Trouve Is Nothing
End If
On Error Resume Next
For A = 4 To 38 Step 4
.Range("B" & A).ClearContents
.Range("D" & A).ClearContents
.Range("F" & A).ClearContents
.Range("G" & A).ClearContents
.Range("H" & A).ClearContents
Next
For A = 6 To 38 Step 4
.Range("B" & A).ClearContents
.Range("D" & A).ClearContents
.Range("H" & A).ClearContents
Next
End With
End With
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

 

[MAN]

Re : Rectificatif de la macro ajout feuille

je ne trouve toujours pas le chemin je ma casse la tete depuis le matin