VBA Request

[elketa1252]

Hey guys, I have a request If anyone could help me. Attached is a sample of a workbook explaining what I want. Basically, the tab called data is the data I have and I would like a VBA to clear the group of cells that has over 4000 and keep the ones that are 4000 and under. The tab called results has what I want it to look like when I run the VBA. Sorry for my english, trying my best .

Thank you in advance.

[Paul_Hossler]

This is similar to the other one

Put your cursor on a VBA term and hit F1 to get some online help.

Try .CurrentRegion for example

Option Explicit
Sub DeleteOver4000()
    Dim i As Long, iLast As Long, j As Long
    Dim r As Range
    
    Application.ScreenUpdating = False
    
    With Worksheets("Data")
        iLast = .Cells(1, .Columns.Count).End(xlToLeft).Column
        
        For i = 1 To iLast Step 5
            Set r = .Cells(1, i).CurrentRegion
            
            'important to go bottomn to top (that's the Step -1) when deleting
            For j = r.Rows.Count To 1 Step -1
                If r.Cells(j, 4) > 4000 Then r.Rows(j).Delete Shift:=xlUp
            Next j
        Next i
    
    End With
    Application.ScreenUpdating = True
End Sub

[elketa1252]

Thanks a lot Paul Hossler, I have tried and tried to learn VBA but I feel like If I don't have anybody next to me so I can ask question and get the answer right away, it feels so difficult to me. I used to do all of this cell by cell and then I found out about VBA but I have tried to make meaning of all those things you guys use like for example letter i I see everywhere and stuff and I just can't put it together. One last thing, is there a way I can sort all the data before clearing them? I would like to sort all of them from highest to lowest. Thanks in advance, I really appreciate the time you are saving me. Thanks a lot. Oh and please let me know if I should create a new thread for this request. Thanks.

[rlv]

Alternate (per snb's approach in the other thread)

Sub DeleteOver4000_2()
    Dim R As Range, CellGroup As Range
    Dim CollectionOfRanges As Areas

    With ActiveSheet
        Set CollectionOfRanges = Rows("1:" & .Rows.Count).SpecialCells(xlCellTypeConstants).Areas

        For Each CellGroup In CollectionOfRanges
            For Each R In CellGroup
                If IsNumeric(R.Value) And R.Value > 4000 Then
                    Application.Intersect(R.EntireRow, CellGroup).Rows(1).Delete Shift:=xlUp
                End If
            Next R
    Next CellGroup
    End With
End Sub

[elketa1252]

Is there anyway I can sort the data I am left with from highest to lowest for each group?

[rlv]

Sub DeleteOver4000_2()
    Dim R As Range, CellGroup As Range
    Dim CollectionOfRanges As Areas


    With ActiveSheet
        Set CollectionOfRanges = Rows("1:" & .Rows.Count).SpecialCells(xlCellTypeConstants).Areas
        
        For Each CellGroup In CollectionOfRanges
            For Each R In CellGroup
                If IsNumeric(R.Value) And R.Value > 4000 Then
                    Application.Intersect(R.EntireRow, CellGroup).Rows(1).Delete Shift:=xlUp
                End If
            Next R
            CellGroup.Sort Key1:=CellGroup.Range("A4"), Order1:=xlDescending
        Next CellGroup
    End With
End Sub