Option Explicit

Sub Перенести_отфильтрованные()
    Dim rTarget As Range
    Set rTarget = Sheets("Лист2").Range("D8")
    
    Dim arr As Variant
    arr = GetArr(Sheets("Лист3").Range("A2"))
    rTarget.Resize(rTarget.Parent.UsedRange.Rows.Count, UBound(arr, 2)).ClearContents
    rTarget.Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub

Private Function GetArr(rSource As Range) As Variant
    Dim aSource As Variant, aTarget As Variant
    aSource = rSource.Resize(rSource.Parent.UsedRange.Rows.Count).Value
    ReDim aTarget(1 To UBound(aSource, 1), 1 To 2)
    Dim ys As Long, yt As Long
    For ys = 1 To UBound(aSource, 1)
        If Not IsEmpty(aSource(ys, 1)) Then
            If Not rSource.Cells(ys, 1).EntireRow.Hidden Then
                yt = yt + 1
                aTarget(yt, 1) = yt
                aTarget(yt, 2) = aSource(ys, 1)
            End If
        End If
    Next
    GetArr = aTarget
End Function

=СУММПРОИЗВ(ПРОМЕЖУТОЧНЫЕ.ИТОГИ(3;СМЕЩ(Лист3!$B$1;СТРОКА(Лист3!$B$26:$B$50)-1;0))*(Лист3!$B$26:$B$50=Лист3!H2))