Sub Заполнить()
    
    Dim shSrc As Worksheet, shRes As Worksheet
    Dim arrSrc(), arrRes()
    Dim lr As Long, i As Long
    
    Application.ScreenUpdating = False
    
    Set shSrc = Worksheets("Лист1")
    Set shRes = Worksheets("Лист2")
    
    shSrc.AutoFilterMode = False
    
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    arrSrc() = shSrc.Range("A3:A" & lr).Value
    ReDim arrRes(1 To UBound(arrSrc), 1 To 1)
    For i = 2 To UBound(arrSrc) Step 2
        arrRes(i - 1, 1) = arrSrc(i, 1)
    Next i
    shSrc.Range("K3:K" & UBound(arrRes)).Value = arrRes()
    
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    shSrc.Range("K2:K" & lr).AutoFilter Field:=1, Criteria1:="<>"
    
    lr = shRes.Cells(shRes.Rows.Count, "A").End(xlUp).Row
    If lr > 2 Then
        shRes.Rows("3:" & lr).Delete
    End If
    
    lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
    shSrc.Range("A3:K" & lr).Copy shRes.Range("A3")
    shSrc.AutoFilterMode = False
    
    Application.ScreenUpdating = True
    MsgBox "Готово!", vbInformation

End Sub