Looking for a Excel Macro to delete rows which doesn’t contain a value in particular cell

[Antariksh]

Guys I need your help to create a Excel macro. I am working on a Excel sheet which is contains lots of information about different departments in a company. I am looking for a Excel Macro with help of which I can delete every rows from the Excel sheet except the rows which contains some specified values in the specified cell and those values I will enter whole running the script. For example in department column every department is having different code no. and suppose I want only 3,5,6,8,12,14,18 departments and others rows should be deleted. Please help I have to finish it as soon as possible.

[Dakshesha]

Dude I am also looking for such Macro, I completely new to these things. I don’t know anything about VBA, this is my first time I to use it, please help us out. I had tried few things but things did not worked for me, I want to delete all the rows except some specified value in a column. I want to use the simple approach given in Excel macro, in which we have to highlight a cell’s value to keep that row and delete all other rows. I tried it I got the message box when I pasted the macro but the value, which I highlighted before running the macro, were not shown. And I clicked on OK in message box and got the error “Microsoft Visual Basic,error 400”.

[void]

Yes, I got it what you need exactly in you Excel Macro. I worked a lot on this and took lots of time to figure out what will be the code or answer and finally I have got the suitable Macro. Your task will be very simple you just have to highlight the column and then run this macro. And then there will be a message box where you have to the value which you want to keep. And let me tell you this macro will work for sheets with up to 25,000 rows.
Code:-

Sub DeleteRows() 
Dim strToDelete As String 
Dim rangSrc As Range 
Dim NumOfRows As Integer 
Dim ThisRow As Integer 
Dim ThatRow As Integer 
Dim ThisColumn As Integer 
Dim J As Integer 
Dim TotaNumOflDeletedRows As Integer 
strToDelete = InputBox("Value to Trigger Keep, David????", "Delete Rows") 
Set rangSrc = ActiveSheet.Range(ActiveWindow.Selection.Address) 
NumOfRows = rangSrc.Rows.Count 
ThisRow = rangSrc.Row 
ThatRow = ThisRow + NumOfRows - 1 
ThisColumn = rangSrc.Column 
Dim topOfRows As Integer 
Dim bottomOfRows As Integer 
bottomOfRows = 25000 
For J = ThisRow To NumOfRows Step 1 
If Cells(J, ThisColumn) = strToDelete Then 
'Rows(J).Select 
topOfRows = J 
Exit For 
TotaNumOflDeletedRows = TotaNumOflDeletedRows + 1 
End If 
Next J 
For J = (topOfRows + 1) To NumOfRows Step 1 
If Cells(J, ThisColumn) <> strToDelete Then 
'Rows(J).Select 
bottomOfRows = J 
Exit For 
'TotaNumOflDeletedRows = TotaNumOflDeletedRows + 1 
End If 
Next J 
If topOfRows <> 4 Then 
ActiveSheet.Range(Cells(4, 1), Cells(topOfRows - 1, 52)).Select 
Selection.delete Shift:=xlUp 
End If 
ActiveSheet.Range(Cells(bottomOfRows - topOfRows + 4, 1), Cells(30000, 52)).Select 
Selection.delete Shift:=xlUp 
'MsgBox "Total Number of deleted rows: " & TotaNumOflDeletedRows 
End Sub

[!const]

I had solved similar kind of problem for somebody and I think the similar code will work for you. I have that Macro code you can check if it works for you. Best of luck
Code:-

Option Explicit
'linearDeletion by Jacobs 04.04.2011
‘This Macro will enable you to delete not required rows and will give required rows only’

Dim strToKeep       As String  'string that let us keep a row that contains it
Dim strToCompare    As String  'string taken from a cell(x, y)
Dim rangSrc          As Range   'field size to operate, search and delete
Dim NumOfRows         As Long    'total number of selected rows to operate, search and delete
Dim selectColumn          As Long    'sel[ected] column
Dim selectRow           As Long    'sel[ected] row
Dim compOut         As Integer 'com[pare] out - returns 0 in case of no match or >0 if there is a match
Dim actRow          As Long    'act[ual] row - used temporary in For/Next loop
Dim J               As Long    'for For/Next loop
Dim NameOfSheet       As String  'keeps sheet's name (different languages have it under different name)
Dim TotaNumOflDeletedRows     As Long    'just for an information how much rows were deleted

Private Sub cmdStart_Click()
    Call linearOperation
End Sub

Private Sub linearOperation()

    strToKeep = InputBox("Write a (part of) string you want to keep as a whole row:", "Keep Rows")
    If strToKeep = "" Then Exit Sub 'nothing to compare so... exit
    'strToKeep = "your string" 'you may use it instead of InputBox window
    Set rangSrc = ActiveSheet.Range(ActiveWindow.Selection.Address) 'sets the field size

    NumOfRows = rangSrc.Rows.Count 'total number of selected rows
    selectColumn = rangSrc.Column      'selected column
    selectRow  = rangSrc.Row         'selected row
    
    NameOfSheet = ActiveSheet.Name 'reads active sheet's name
    
    TotaNumOflDeletedRows = 0 'have to start from the scratch
        
    actRow = selectRow  'actRow will change so we need to leave 'selectRow ' intact
    
    For J = selectRow  To NumOfRows
        strToCompare = Worksheets(NameOfSheet).Cells(actRow, selCol) 'reads a string from cell(x, y)
        compOut = InStr(1, strToCompare, strToKeep, vbTextCompare) 'makes comparison and gives its result
        If strToCompare = "" Then compOut = 1 'cell(x, y) is empty so lets fool it to not deleting
        If compOut = 0 Then                           'not found the string we are looking for so...
            Worksheets(NameOfSheet).Rows(actRow).Select '...selects actual row,...
            Selection.Delete Shift:=xlUp              '...deletes it and shifts all rows up
            actRow = actRow - 1 'we have one row less so we need to mark this for strToCompare
            TotaNumOflDeletedRows = TotaNumOflDeletedRows + 1 'counts deleted rows
        End If
        actRow = actRow + 1 'comparison is done so we need to increase this array to give the correct number to strToCompare
    Next J
    
    MsgBox "Number of deleted rows: " & TotaNumOflDeletedRows

End Sub

[Antariksh]

I want to thank all of you for your suggestions and solutions, I didn’t expected that somebody will solve my problem just like that in few minutes. These forums are really very active. I had posted same problem on other forums too get solution but I didn’t get any reply yet on those forums. I tried only first solution and it worked for me and completed the task in no time, Thanks again for the help and now I will visit these forums to get help or to help others.

[jarochnrol]

I am looking for a variation of this. I have a table of action items that are still open, and Amy Bob, and Charlie are on my team.

When I run a report, the table shows the current asignee in column N. I need a macro that sorts according to column N and deletes everybody except Amy, Bob and Charlie.

Item # Info Asignee
1 info1 David
2 info2 Bob
3 info3 Amy
4 info4 Charlie
5 info5 Greg


Item # Info Asignee
3 info3 Amy
2 info2 Bob
4 info4 Charlie

Thanks!

[Janos™]

Hi jarochnrol,

You can try to use the below:
'===========================>>
Public Sub Tester03()
Dim rng As Range

Set rng = Intersect(ActiveSheet.UsedRange, Columns("D"))

On Error Resume Next
rng.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0

End Sub
'===========================>>

Or use the built in autofilter feature.