Improve performance of "For.. Each...If ..... next" code

[Alroj]

Hi Team,

I have this code that I use to calculate the difference between "1Act" minus "2Act" and place the result in "3Act". All these 3 names are located in column A and they are organised by the name of the event located column 4. So, what I am doing is if the name of the event (located in column 4) matches for "1Act", "2Act", "3Act" (located in column A) then the macro calculates the difference and copy the formula across columns for different days and then copy the formulas as values.

This macro works BUT it is slow. I am hoping you may be able to help me improve the performance of the below code please

Much appreciated

 Range("A1:az8").Select
 Selection.Find(What:="Combination", LookIn:=xlValues, LookAt:=xlWhole).Offset(1, 0).Select

 
 For Each cell In Range(ActiveCell, ActiveCell.End(xlDown))
 If cell.Value = "3Act" Then
  cell.Offset(0, 4).FormulaR1C1 = "=SUMIFS(R9C:R400C,R9C1:R400C1,""1Act"",R9C4:R400C4,RC4)-SUMIFS(R9C:R400C,R9C1:R400C1,""2Act"",R9C4:R400C4,RC4)"
  cell.Offset(0, 4).Copy
  Range(cell.Offset(0, 4), cell.Offset(0, 4).End(xlToRight)).Select
   Selection.PasteSpecial Paste:=xlFormulas
   Selection.Copy
   Selection.PasteSpecial Paste:=xlPasteValues
   Application.CutCopyMode = False
 End If
            
Next

 

[kvsrinivasamurthy]

Try.

Dim Frng As Range
Set Frng = Range("A1:az8").Find(What:="Combination", LookIn:=xlValues, LookAt:=xlWhole).Offset(1, 0)
If Not Frng Is Nothing Then
 For Each cell In Range(Frng, Frng.End(xlDown))
 If cell.Value = "3Act" Then
  Range(cell.Offset(0, 4), cell.Offset(0, 4).End(xlToRight)).FormulaR1C1 = "=SUMIFS(R9C:R400C,R9C1:R400C1,""1Act"",R9C4:R400C4,RC4)-SUMIFS(R9C:R400C,R9C1:R400C1,""2Act"",R9C4:R400C4,RC4)"
 End If

Next
End If