Copying Data without overwriting (edit macro)

Option Explicit
Option Base 1

Sub CopyData()
Dim MyRg As Range
Dim MyData()
Dim SrchRg As Range
Dim MyVal As Range
Dim F
Dim ColSRC, ColDEST
Dim I As Integer
Dim TextVal As String
Dim NbCol As Integer
    NbCol = 3           '  NB OF COLUMNS TO TREAT
    ReDim MyData(NbCol)
    ColSRC = Array("D", "F", "H")  '  HERE  TO MENTION COLUMNS IN SHEET 1  WHERE TO GET DATA
    ColDEST = Array("F", "D", "I") '  HERE  TO MENTION COLUMNS IN SHEET 2  WHERE TO PÜT DATA
    
    With Sheets("Sheet1")
        Set MyRg = .Range(.Range("C5"), .Range("C" & Rows.Count).End(xlUp))
        On Error Resume Next
        For Each MyVal In MyRg
            For I = 1 To NbCol
                MyData(I) = .Cells(MyVal.Row, ColSRC(I))
            Next I
            
            With Sheets("Sheet2")
                Set SrchRg = .Range(.Range("A1"), .Range("A" & Rows.Count).End(xlUp))
                With SrchRg
                    Set F = .Find(What:=MyVal, After:=.Cells(1, 1), LookIn:=xlValues, _
                            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                            MatchCase:=False)
                    If (Not F Is Nothing) Then
                        For I = 1 To NbCol
                            With .Cells(F.Row, ColDEST(I))
                                If (.Value <> Empty) Then
                                    .AddComment
                                    .Comment.Visible = False
                                    TextVal = .Value
                                    .Comment.Text Text:=TextVal
                                End If
                                .Value = MyData(I)
                            End With
                        Next I
                    End If
                End With
            End With
        Next MyVal
    End With
End Sub