Copier/Coller commentaires d'une feuille à une autre avec conditions

Bonjour à tous!

Je suis nouveau dans le développement VBA et j'ai une réalisation à faire pour le travail.

Explications:

Dans la feuille 1, colonne E: J'ai des références de capteurs.

Dans la feuille 2, colonne A: j'ai ces memes valeurs auxquelles correspond, en colonne G, des repères de ces capteurs. Avec en commentaires des informations sur le câblage.

Ce que j'essaye de faire:

Si, dans la feuille 1, colonne E, la valeur est égale à la valeur dans la colonne A de la feuille 2 alors récupéré le commentaire sur la meme ligne mais en colonne G pour ensuite coller le commentaire récupérer en commentaire mais dans la colonne J de la feuille 1.

Je sais comment copier et coller un commentaire en commentaire mais c'est au niveau de l'édition de la boucle et de la declaration des tests pour les cellules que j'ai du mal... J'espère avoir été assez clair dans mes propos.. Si ce n'est pas le cas, n'hésitez pas à me poser d'autre questions.

Je vous laisse on document en pièce jointe. J'ai déja essayer quelque lignes de codes dans celui ci que je vous laisse à disposition également.

Sub CopieCommentaires()
Dim ws_source As Worksheet 'Feuille 1
Dim ws_target As Worksheet 'Feuille 2
Dim cols_source As Range 'Colonne E
Dim cols_recop As Range 'Colonne J
Dim ligne_source As Range
Dim cel_target As Range 'Cellule dans feuille 2 colonne G

Set ws_source = Worksheets("Feuille1")
Set ws_target = Worksheets("Feuille 2")
'Set plage1 = F1.Range("E2:E127")
'Set plage2 = F2.Columns("A")

With ws_source
    Set cols_source = .Columns("E")
    Set cols_recop = .Columns("J")
End With

Set cel_target = ws_target.Range("G")
Set ligne_source = ws_source.Rows(4)

On Error Resume Next

Resultat = Application.VLookup(Range("E4:E130"), F2.Range("A2:G90"), 7, False) 'Fct RECHERCHEV

For Each ligne_source In ws_source.Range(ws_source.Rows(4), ws_source.Rows(130))
    If Intersect(ligne_source, col_source).Value = Intersect(ws_target.Rows(2), cel_target).Value Then
        Intersect(ws_target.Rows(2), cel_target).Copy Destination:=cols_recop
        Set cols_recop = cols_recop.PasteSpecial Paste :=xlPasteComments

  F2.Range("G2:G90").Copy Destination:=F1.

  'For Each Cell In plage1
   ' If Cells.Value = F2.Range("A").Cells.Value Then

    '    F1.Range("K").Cells.PasteSpecial Paste:=xlPasteComments
     '   End If
    'Next Cell

'If Range("E4:E127").Value = F2.Range("A2:A90").Value Then
 '   F2.Range("G2:G90").Copy
  '  F1.Range("K2:K127").PasteSpecial Paste:=xlPasteComments
'End If

End Sub

Bonjour,

une proposition non testée car je ne dispose pas de ton ficheir.

Sub CopieCommentaires()
    Dim ws_source As Worksheet    'Feuille 1
    Dim ws_target As Worksheet    'Feuille 2
    Dim plage1 As Range, plage2 As Range, re As Range
    Dim dlwss As Long, dlwst As Long

    Set ws_source = Worksheets("Feuille 1")
    Set ws_target = Worksheets("Feuille 2")
    With ws_source
        dlwss = .Cells(Rows.Count, 1).End(xlUp).Row
        Set plage1 = .Range("E1:E" & dlwss)
    End With
    With ws_target
        dlwst = .Cells(Rows.Count, 1).End(xlUp).Row
        Set plage2 = .Range("A1:A" & dlwst)
    End With

    For Each ref In plage2
        Set re = plage1.Find(ref.Value, lookat:=xlWhole)
        If Not re Is Nothing Then
            On Error Resume Next
            ws_target.Cells(ref.Row, "J").Value = ws_source.Cells(re.Row, "G").Comment.Text
            On Error GoTo 0
        End If
    Next ref
End Sub

Merci!

Bah normalement j'ai mis le fichier dont je dispose dans le post precedent.

Je te le renvoi ici

Bonjour,

une proposition testée sur ton fichier exemple.

Magnifique!

Merci beaucoup!

C'est ça dont j'avais besoin! Juste une dernière petite modif, est-ce que c'est possible de récupérer les commentaires et de les remettre en commentaires dans les cellules ciblées dans la colonne J?

re-bonjour,

voici

Sub CopieCommentaires()
    Dim ws1 As Worksheet    'Feuille 1
    Dim ws2 As Worksheet    'Feuille 2
    Dim plage1 As Range, plage2 As Range, re As Range
    Dim dlwss As Long, dlwst As Long

    Set ws1 = Worksheets("Feuille1")
    Set ws2 = Worksheets("Feuille 2")
    With ws1
        dlwss = .Cells(Rows.Count, 5).End(xlUp).Row
        Set plage1 = .Range("E1:E" & dlwss)
    End With
    With ws2
        dlwst = .Cells(Rows.Count, 1).End(xlUp).Row
        Set plage2 = .Range("A1:A" & dlwst)
    End With

    For Each ref In plage1
        Set re = plage2.Find(ref.Value, lookat:=xlWhole, MatchCase:=False)
        If Not re Is Nothing Then
            On Error Resume Next
             ws2.Cells(re.Row, "G").Copy ws1.Cells(ref.Row, "J")
            On Error GoTo 0
        End If
    Next ref
End Sub

Merci mille fois h2so4!!!

Peux-tu m'expliquer:

- Cette ligne de code:

 dlwss = .Cells(Rows.Count, 5).End(xlUp).Row 

- Pour la variable "ref" tu la declare directement dans la boucle For?

re-bonjour

 dlwss = .Cells(Rows.Count, 5).End(xlUp).Row 

dlwss N° de ligne de la dernière cellule utilisée en colonne 5

ref, j'ai oublié de la définir, si tu souhaites la définir, il faut ajouter une instruction

dim ref