PDA

View Full Version : [SOLVED] VBA Request



elketa1252
05-19-2017, 05:25 PM
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
05-19-2017, 05:51 PM
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
05-20-2017, 10:51 AM
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
05-20-2017, 11:36 AM
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
05-20-2017, 12:33 PM
Is there anyway I can sort the data I am left with from highest to lowest for each group?

rlv
05-20-2017, 01:20 PM
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