Try this Code

Took away the vlookups and just used simple subtractions

Sub CopyFormula()


Dim WsR As Worksheet 'worksheet report
Dim WsD As Worksheet 'worksheet data

'Report Sheet
Dim FinalRowWsR As Long
Dim FinalColWsR As Long
'Data Sheet
Dim FinalRowWsD As Long
Dim FinalColWsD As Long

Dim MyArray1() As Variant
Dim MyArray2() As Variant

Dim Dta As Long
Dim Crit As Long
Dim c As Long

Dim Crit1 As String
Dim Crit2 As String

Dim Crit1A As Long
Dim Crit2A As Long

Set WsR = ThisWorkbook.Worksheets("Report")
Set WsD = ThisWorkbook.Worksheets("Data")

Application.ScreenUpdating = False

FinalRowWsD = WsD.Cells(Rows.Count, 1).End(xlUp).Row
FinalColWsD = WsD.Cells(1, Columns.Count).End(xlToLeft).Column
FinalRowWsR = WsR.Cells(Rows.Count, 1).End(xlUp).Row
FinalColWsR = WsR.Cells(4, Columns.Count).End(xlToLeft).Column - 1

'loop to find the criteria row on wsd
For Crit = 5 To FinalRowWsR
    Crit1 = WsR.Cells(Crit, 1).Value
    Crit2 = WsR.Cells(Crit, 2).Value
    
    Crit1A = 0
    Crit2A = 0
    
    For Dta = 1 To FinalRowWsD
        Select Case WsD.Cells(Dta, 1).Value
            Case Crit1
                Crit1A = WsD.Cells(Dta, 1).Row
            Case Crit2
                Crit2A = WsD.Cells(Dta, 1).Row
        End Select
        
        If Crit1A And Crit2A <> 0 Then Exit For
        
    Next Dta
    'formula
    ReDim MyArray1(1 To FinalColWsD)
    ReDim MyArray2(1 To FinalColWsD)
    
    MyArray1() = WsD.Range(WsD.Cells(Crit1A, 2), WsD.Cells(Crit1A, FinalColWsD))
    MyArray2() = WsD.Range(WsD.Cells(Crit2A, 2), WsD.Cells(Crit2A, FinalColWsD))
    
    For c = 3 To FinalColWsD + 1
        WsR.Cells(Crit, c).Value = MyArray1(1, c - 2) - MyArray2(1, c - 2)
    Next c
    
    Application.StatusBar = "On Record " & Crit
    
Next Crit

Application.StatusBar = True
Application.ScreenUpdating = True
End Sub