Ajout de valeurs contenu dans des Cell vers d'autre selon multi-crit

Bonjour et merci de votre aide. `

Voici mon problème.

J'aimerais qu'en appuyant sur le bouton Ajouter, les données situées de F4 à I4, s'ajoute automatiquement au bon endroit selon les critères entré en D4, E4, C4 dans les différent tableau dans la même feuille. Dans le tableau B2, le critère A est en double, j'aimerais si possible que le code vérifie s'il y a une donnée dans la premiere ligne correspondant au critère A et si oui, l'ajouter dans la 2e ligne. J'aimerais aussi que s'il y a déjà du texte dans une des lignes, qu'un msgBox apparaisse pour le dire avec la possibilité de remplacer le texte déjà présent par le nouveau et ce pas juste dans le tableau. Une fois la procédure effectuer, je ne souhaite pas que les infos entrées de C4 à I4 s'efface et cela pour permettre des ajouts plus rapide.

Je n'ai pas de grande connaissance VBA et je suis certain que cela n'est pas une question difficile pour plusieurs d'entre vous.

Je vous remercie énormément de prendre le temps de me répondre.

P.S. en pièce jointe j'ai mis mon fichier test. Si vous nécessitez plus d'information il me fera un grand plaisir de vous les donner.

Bonjour,

à tester,

Sub Tranfert()
Dim R As Range
Dim Adr As String

Set R = Columns(1).Find(Range("E4"), Range("A8"))

If R Is Nothing Then Exit Sub
If Cells(R.Row - 2, 3) = Range("D4") Then Adr = R.Address

Do
    Set R = Columns(1).FindNext(R)
    n = R.Row
    If Cells(R.Row - 2, 3) = Range("D4") Then Adr = R.Address
Loop While Not R Is Nothing And R.Address <> Adr     

RW = Range(Adr).Row + Range("C4") - 1

If Range("c" & RW) <> "" Then
    MsgBox "déjà renseigné"
Else
    Cells(RW, "C").Value = Cells(4, "F").Value
    Cells(RW, "D").Value = Cells(4, "G").Value
    Cells(RW, "E").Value = Cells(4, "H").Value
    Cells(RW, "F").Value = Cells(4, "I").Value
End If

Set R = Nothing
End Sub

Bonjour,

après quelque test j'ai trouvé des problèmes,

voici la correction:

Sub Tranfert()
Dim R As Range
Dim Adr As String

LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Set R = Range("A10:A" & LastRow).Find(Range("E4"), Range("A10"))

    If R Is Nothing Then Exit Sub
      n1 = R.Row
    If Cells(R.Row - 2, 3) = Range("D4") Then Adr = R.Address

Do
    Set R = Range("A10:A" & LastRow).FindNext(R)
    n2 = R.Row
    If n1 = n2 And Cells(R.Row - 2, 3) = Range("D4") Then
      Adr = R.Address
    Else
      MsgBox Range("E4") & " avec " & Range("D4") & " : données non trouvé"
      Exit Sub
    End If
Loop While Not R Is Nothing And R.Address <> Adr      

RW = Range(Adr).Row + Range("C4") - 1

If Range("c" & RW) <> "" Then
    MsgBox "déjà renseigné"
Else
    Cells(RW, "C").Value = Cells(4, "F").Value
    Cells(RW, "D").Value = Cells(4, "G").Value
    Cells(RW, "E").Value = Cells(4, "H").Value
    Cells(RW, "F").Value = Cells(4, "I").Value
End If
End Sub