remove cells with minus value and adjacent cells

[redspanna]

Can someone help with code that will look down range B1:B50 and when a minus sum is found, delete that cell and the adjacent value in column A, then remove those blank cells. Not remove entire row - just blank cells in columns A:B


example


[table="width: 150, class: grid"]
[tr]
[td]Test 1[/td]
[td]200[/td]
[/tr]
[tr]
[td]Test 2[/td]
[td]-300[/td]
[/tr]
[tr]
[td]Test 3[/td]
[td]1345[/td]
[/tr]
[/table]

would result after code...

[table="width: 150, class: grid"]
[tr]
[td]Test 1[/td]
[td]200[/td]
[/tr]
[tr]
[td]Test 3[/td]
[td]1345[/td]
[/tr]
[/table]

Thanks in advnce

 

[steve the fish]

Try this:

Dim sh As Worksheet, lr As Long, rng As Range, c As Range

Set sh = Sheets("Sheet1")
lr = sh.Range("B" & sh.Rows.Count).End(xlUp).Row

For Each c In sh.Range("B1:B" & lr)
    If c < 0 Then
        If Not rng Is Nothing Then
            Set rng = Union(rng, c)
        Else
            Set rng = c
        End If
    End If
Next
If Not rng Is Nothing Then
    Union(rng, rng.Offset(, -1)).Delete Shift:=xlUp
End If

 

[nemmi69]

How about this?

Option ExplicitDim RowLoop As Long
Dim LastRowNo As Long


Sub Macro1()
'
LastRowNo = ActiveSheet.Range("B65536").End(xlUp).Row 'set range to 1048576 if your sheet can go that high


For RowLoop = LastRowNo To 1 Step -1
    If ActiveSheet.Range("B" & RowLoop).Value < 0 Then
        Range("A" & RowLoop & ":B" & RowLoop).Delete Shift:=xlUp
    End If
Next RowLoop
End Sub

 

[redspanna]

Thanks a lot guys - help much appreciated