Inserting a row when a list of sorted numbers change from positive to negative

[rammi125]

I have a list of numbers sorted in column L from largest to smallest. I want to insert a line when the numbers switch from positive to negative. My code right now is just inserting a row wherever the cell is when I run my macro, can you tell me what I'm doing wrong?


Dim i As Long

i = 3

Do While Range("L" & i) <> ""
If checksign(Range("L" & i)) <> checksign(Range("L" & i - 1)) Then
ActiveCell.EntireRow.Insert shift:=xlDown
i = i + 1 'Shift downward after insert a row
End If
i = i + 1

Loop

End Sub

Function checksign(cells As Range) As String

' check if the sign of lastcell is different from the previous one
If cells < 0 Then
checksign = "Negative"
Else
checksign = "Positive"
End If

End Function

 

[JackDanIce]

Assuming the data is sorted in descending order, try:

Sub macro_1()

Dim i As Long

    Application.ScreenUpdating = False

    For i = 3 To Range("L" & Rows.Count).End(xlUp).Row
        If Range("L" & i).Value < 0 Then
            Range("L" & i).EntireRow.Insert shift:=xlDown
            Exit For
        End If
    Next i

    Application.ScreenUpdating = True

End Sub

 

[Snakehips]

A non looping option. Could be faster if to be used on a large data set?

Sub macro_1()


lr = Range("L" & Rows.Count).End(xlUp).Row
Fstneg = Application.Match(0, Range("L3:L" & lr), -1) + 3
If Range("L" & Fstneg) < 0 Then
Range("L" & Fstneg).EntireRow.Insert shift:=xlDown
End If
    
End Sub

 

[rammi125]

Thanks for your response. I changed the code to the below. On the line "For i = 3 To Range("L" & rows.Count).End(xlUp).Row" I get a 424 error object required pop up message.


Dim i As Long

Application.ScreenUpdating = False

For i = 3 To Range("L" & rows.Count).End(xlUp).Row
If Range("L" & i).value < 0 Then
Range("L" & i).EntireRow.Insert shift:=xlDown
Exit For
End If
Next i

Application.ScreenUpdating = True

End Sub

Function checksign(cells As Range) As String

' check if the sign of lastcell is different from the previous one
If cells < 0 Then
checksign = "Negative"
Else
checksign = "Positive"
End If

End Function

 

[JackDanIce]

I'm not getting the pop up error on line For i = 3 To Range("L" & rows.Count).End(xlUp).Row

You only need this part of the code:

Sub m1()

Dim i As Long

Application.ScreenUpdating = False

For i = 3 To Range("L" & Rows.Count).End(xlUp).Row
    If Range("L" & i).Value < 0 Then
        Range("L" & i).EntireRow.Insert shift:=xlDown
        Exit For
    End If
Next i

Application.ScreenUpdating = True

End Sub

There is nothing in the above that calls the function checksign

 

[rammi125]

I tried using your code and it works perfectly. For some reason though when I put it in with my code I'm getting the error. The first part of my code deletes every number that is between .01 and -.01.

This should hopefully be my last question. Can you take a look at the code below (this is everything) and tell me what I'm doing wrong resulting in the error?

Sub Macro1()

Dim rows As Range, cell As Range, value As Double

Set cell = Range("l3")
Do Until cell.value = ""
value = Val(cell.value)
If (value > -0.01 And value < 0.01) Then
If rows Is Nothing Then
Set rows = cell.EntireRow
Else
Set rows = Union(cell.EntireRow, rows)
End If
End If
Set cell = cell.Offset(1)
Loop

If Not rows Is Nothing Then rows.Delete

Dim i As Long

Application.ScreenUpdating = False

For i = 3 To Range("L" & rows.Count).End(xlUp).Row
If Range("L" & i).value < 0 Then
Range("L" & i).EntireRow.Insert shift:=xlDown
Exit For
End If
Next i

Application.ScreenUpdating = True

End Sub

 

[JackDanIce]

Including Snakehips suggestion, try:

Sub Macro2()

Dim LR  As Long
Dim x   As Long

    Application.ScreenUpdating = False
    
    With ActiveSheet
        
        If .AutoFilterMode Then .AutoFilterMode = False
    
        LR = .Range("L" & .rows.Count).End(xlUp).Row
        
        With .Range("L3").Resize(LR)
            .AutoFilter
            .AutoFilter field:=1, Criteria1:=">=-0.01", Operator:=xlAnd, Criteria2:="<=0.01"
            .Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
        End With
        
        .AutoFilterMode = False
        
        LR = .Range("L" & .rows.Count).End(xlUp).Row
        
        x = Application.Match(0, .Range("L3").Resize(LR), -1) + 3
        
        If .Range("L" & x).value < 0 Then
            .Range("L" & x).EntireRow.Insert shift:=xlDown
        End If
        
    End With
        
    Application.ScreenUpdating = True
        
End Sub