Dim k As Long
For k = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
   If Cells(k, 1).Value = "" Then
       Rows(k).Delete Shift:=xlUp
   End If
Next k

Sub Макрос2()
Dim a As Long
Dim arr As Variant
a = Cells(Rows.Count, 2).End(xlUp).Row
arr = Cells(2, 1).Resize(a, 2)
For a = 1 To UBound(arr, 1)
    If arr(a, 2) < 0 Then
        Cells(2, 4).Value = arr(a, 1)
        Exit For
    End If
Next
For a = 1 To UBound(arr, 1)
    If arr(a, 2) > 0 Then
        Cells(2, 5).Value = arr(a, 1)
        Exit For
    End If
Next
End Sub

Sub Макрос1()
Columns("B:B").AutoFilter Field:=1, Criteria1:="<0"
a = Cells(Rows.Count, 2).End(xlUp).Row
Stop
Range(Cells(2, 1), Cells(a, 1)).Copy 'Нужно скопировать значение только первой строки результата автофильтра
Cells(2, 4).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:B").AutoFilter
Stop
Columns("B:B").AutoFilter Field:=1, Criteria1:=">0"
a = Cells(Rows.Count, 2).End(xlUp).Row
Stop
Range(Cells(2, 1), Cells(a, 1)).Copy 'Нужно скопировать значение только первой строки результата автофильтра
Cells(2, 5).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Columns("B:B").AutoFilter
End Sub

Sub addRedBox()

Dim redBox As Shape
Dim selectedAreas As Range
Dim i As Integer
Dim tempShape As Shape

'Loop through each selected area in active sheet
For Each selectedAreas In Selection.Areas

    'Create a rectangle
    Set redBox = ActiveSheet.Shapes.AddShape(msoShapeRectangle, _
        selectedAreas.left, selectedAreas.top, _
        selectedAreas.Width, selectedAreas.Height)

    'Change attributes of shape created
    redBox.Line.ForeColor.RGB = RGB(255, 0, 0)
    redBox.Line.Weight = 2
    redBox.Fill.Visible = msoFalse
    'Loop to find a unique shape name
    Do
        i = i + 1
        Set tempShape = Nothing
        
        On Error Resume Next
        Set tempShape = ActiveSheet.Shapes("RedBox_" & i)
        On Error GoTo 0
    
    Loop Until tempShape Is Nothing
    
    'Rename the shape
    redBox.Name = "RedBox_" & i
Next

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Not Intersect(Target, Range("B3:B32, D2:Y2")) Is Nothing Then
        Range("A1") = Target
    Else: End If
End Sub