Sub deleterows()
    On Error Resume Next
    arr = [a1:d15]
    arr2 = DeleteBlankRows(arr, [1])
    
    [A1].Resize(UBound(arr2, 1), UBound(arr2, 2)).Value = arr2
End Sub

Function DeleteBlankRows(ByVal arr As Variant, ByVal col As Long) As Variant
    If Not IsArray(arr) Then MsgBox "Это не массив!", vbCritical: Exit Function
    If col > UBound(arr, 2) Then MsgBox "Нет такой строки в массиве!", vbCritical: Exit Function
    If col < LBound(arr, 2) Then MsgBox "Нет такой строки в массиве!", vbCritical: Exit Function

   [A1:D15].clearcontents

    Dim iCount As Long
    For i = LBound(arr) To UBound(arr)
        iCount = iCount - (arr(i, col) <> "")
    Next i

    ReDim narr(LBound(arr, 1) To iCount + LBound(arr, 1) - 1, LBound(arr, 2) To UBound(arr, 2))

    iCount = LBound(narr)
    For i = LBound(arr, 1) To UBound(arr, 1)
        If arr(i, col) <> "" Then
            For j = LBound(arr, 2) To UBound(arr, 2)
                narr(iCount, j) = arr(i, j)
            Next j
            iCount = iCount + 1
        End If
    Next i

    DeleteBlankRows = narr
End Function