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:-
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
Bookmarks