Sub find_values()
  Dim i&, j&, r_ap&, r_sv&
  r_ap = Sheets("ap").Cells(Rows.Count, 3).End(xlUp).Row
  r_sv = Sheets("sv").Cells(Rows.Count, 3).End(xlUp).Row
  For i = 4 To r_ap
    For j = 2 To r_sv
       If sv.Cells(j, 3).Value = ap.Cells(i, 3).Value And sv.Cells(j, 10) = "Кол-во фэйсов Всего" Then
        ap.Cells(i, 13).Value = sv.Cells(j, 15).Value
       End If
    Next j
  Next i
End Sub

Sub ertert()
Dim x, y(), j&, k&, r As Range, adr$, fc
Dim col As New Collection

'1
x = ap.Range("C4", ap.Cells(Rows.Count, 3).End(xlUp)).Value 'находим последнюю строку в 3м столбце на вкладке AP
ReDim y(1 To UBound(x), 1 To 8) 'Переназначаем переменную y - массив (от 1 до последней строки , fc (1 до 8))
fc = ap.Range("I3:P3").Value 'данные из шапки по которым идет поиск

On Error Resume Next: Err.Clear ' пропускаем и очищаем ошибки
For j = 1 To UBound(x) 'цикл добавления в коллекцию значений из 3 столбца вкладки AP
    col.Add Item:=j, Key:=CStr(x(j, 1))
Next j

'2
With sv.Columns(10)
    For j = 1 To UBound(fc, 2)
        If Len(fc(1, j)) Then
            Set r = .Find(fc(1, j), LookIn:=xlValues, lookat:=xlWhole)
            If Not r Is Nothing Then
                adr = r.Address
                Do
                    If Not IsEmpty(col.Item(CStr(r(1, -6).Value))) Then
                        k = col.Item(CStr(r(1, -6).Value))
                        y(k, j) = r(1, 6).Value
                    End If
                    Set r = .FindNext(r)
                Loop While r.Address <> adr
            End If
        End If
    Next j
End With

ap.Range("I4:P4").Resize(UBound(y)).Value = y()
End Sub