Automatically copy a cell

[etheer]

Hi
I need help edit code macro automatically copy of cell and paste to other cell
I need also copy cells and past in row 4

Private Sub Worksheet_Calculate()
    Dim c As Range
    Application.EnableEvents = False
    On Error Resume Next
    For Each c In Range("H7:H" & Cells(Rows.Count, "H").End(xlUp).Row)
        If c = "Yes" Then
            c.Offset(, 1).Value = "Yes"
            If c.Offset(, 2) = "" Then
                c.Offset(, 2).Value = c.Offset(, -7).Value
                c.Offset(, 3).Value = c.Offset(, -6).Value
                c.Offset(, 4).Value = c.Offset(, -5).Value
                c.Offset(, 5).Value = c.Offset(, -2).Value
    
            End If
        End If
    Next c
    Application.EnableEvents = True
End Sub

excelpic.jpg