Sub Перенести()

    Dim shSrc As Worksheet, shRes As Worksheet
    Dim lrSrc As Long, lrRes As Long
    
    Set shSrc = Worksheets("Форма")
    Set shRes = Worksheets("Списки")
    lrSrc = shSrc.Cells(shSrc.Rows.Count, "C").End(xlUp).Row
    If lrSrc < 3 Then
        Exit Sub
    End If
    lrRes = shRes.Cells(shRes.Rows.Count, "C").End(xlUp).Row + 1
    Application.ScreenUpdating = False
    shSrc.Rows("3:" & lrSrc).Columns("B:H").Copy
    shRes.Cells(lrRes, "B").PasteSpecial (xlPasteValues)
    Application.CutCopyMode = False
    shSrc.Range("C3:C" & lrSrc).ClearContents
    Application.ScreenUpdating = True

End Sub

Sub Перенести()

    Dim shSrc As Worksheet, arrSrc(), shRes As Worksheet
    Dim lr As Long, r As Long, i As Long
    
    Set shSrc = Worksheets("Форма")
    Set shRes = Worksheets("Списки")
    lr = shSrc.Cells(shSrc.Rows.Count, "C").End(xlUp).Row
    If lr < 3 Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    arrSrc() = shSrc.Range("A1:H" & lr).Value
    On Error Resume Next
    For i = 3 To UBound(arrSrc)
        r = WorksheetFunction.Match(arrSrc(i, 3), shRes.Columns("C"), 0)
        If Err.Number = 0 Then
            shRes.Cells(r, "H").Value = arrSrc(i, 8)
            shSrc.Cells(i, "C").ClearContents
        Else
            Err.Number = 0
        End If
    Next i
    On Error GoTo 0
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation

End Sub