Need improve speed of transpose & delete row shiftUp (11 minutes)

Hello All,
I had someone help me with the code below from this forum. The code works fine but now if I run 500 rows, its much slower (11 minutes). I appreciate it if I could get some help on my code to make it faster or if there are any alternative methods that could improve the speed.

Regards,
tt3

Dim DataRNG As Range, DataRw As Range
Dim NR As Long

With ActiveSheet
    Set DataRNG = .Range("B:B").SpecialCells(xlConstants)
    NR = 4
    For Each DataRw In DataRNG
        .Range("T" & NR).Resize(10).Value = Application.WorksheetFunction.Transpose([{1,2,3,3.5,4,4.2,4.5,5,5.5,6}])
        .Range("U" & NR).Resize(10).Value = Application.WorksheetFunction.Transpose([{"A", "B", "C", "D", "E", "F", "G", "H", "I", "J"}])
        .Range("V" & NR).Resize(10).Value = Application.WorksheetFunction.Transpose([{"A1", "B2", "C3", "D4", "E5", "F6", "G7", "H8", "I9", "J0"}])
        .Range("W" & NR).Resize(10).Value = 1
        DataRw.Offset(, 1).Resize(, 8).Copy
        .Range("X" & NR + 1).Resize(8).PasteSpecial xlPasteAll, Transpose:=True
        DataRw.Offset(, 9).Copy .Range("Y" & NR + 4)
        .Range("Z" & NR).Resize(9, 2).Value = "No"
        .Range("Z" & NR + 9).Resize(, 2).Value = "Yes"
        .Range("T" & NR).CurrentRegion.Borders.Weight = xlThin
        .Range("S" & NR).Value = DataRw.Value
        .Range("R" & NR).Value = DataRw.Offset(, -1).Value
        NR = NR + 11
    Next DataRw
End With
    
''''''''Delete Row with Value 0''''''''
    Dim myrng As Range, i As Long
 For i = 4 To Cells(Rows.Count, "x").End(xlUp).Row
    If Not Cells(i, "x") = vbNullString Then
        If Cells(i, "x") = 0 Then
            If myrng Is Nothing Then
                Set myrng = Range(Cells(i, "r"), Cells(i, "aa"))
            Else
                Set myrng = Union(myrng, Range(Cells(i, "r"), Cells(i, "aa")))
            End If
        End If
    End If
 Next i
 If Not myrng Is Nothing Then
    myrng.Delete Shift:=xlUp
 End If