V
VexedFist
'Basically I need to sort through all of the rows on a worksheet.
'If the cell value in Column "I" equals the cell value in Cell "B2",
then
'I keep the ROW, ELSE DELETE the ROW. Here is what I have so far.
'One NOTE: The Data in Cell C2 has Extra spaces that need to be
Trimmed off First.
'I use this to sort through Multiple worksheets changing from Cell
Value C2 to C3, C4 etc.
Dim SAVESTR As String
If Sheets("RCM").Range("C2") = "" Then
Else
SAVESTR = Sheets("RCM").Range("C2").Value
End If
Sheets("Hardware (2)").Activate
Columns("I:I").Select
On Error Resume Next
Selection.Find(What:=SAVESTR, After:=ActiveCell,
LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False).Activate
If Err.Number <> 91 And Err.Number <> 0 Then
MsgBox "Unresolved Error"
Exit Sub
End If
If ActiveCell.Row > 1 Then
Set myRange = Range("I1").Resize(Range( _
"I" & Rows.Count).End(xlUp).Row, 1)
For Each cell In myRange
If cell.Value <> SAVESTR Then
If delRange Is Nothing Then
Set delRange = cell
Else
Set delRange = Union(delRange, cell)
End If
End If
Next cell
If Not delRange Is Nothing Then delRange.EntireRow.Delete
Range("B1").Select
Selection.EntireRow.Insert
Else
Columns("A:A").ColumnWidth = 2
End If
Application.ScreenUpdating = False
End Sub
'Any And all suggestions will be appreciated.
'If the cell value in Column "I" equals the cell value in Cell "B2",
then
'I keep the ROW, ELSE DELETE the ROW. Here is what I have so far.
'One NOTE: The Data in Cell C2 has Extra spaces that need to be
Trimmed off First.
'I use this to sort through Multiple worksheets changing from Cell
Value C2 to C3, C4 etc.
Dim SAVESTR As String
If Sheets("RCM").Range("C2") = "" Then
Else
SAVESTR = Sheets("RCM").Range("C2").Value
End If
Sheets("Hardware (2)").Activate
Columns("I:I").Select
On Error Resume Next
Selection.Find(What:=SAVESTR, After:=ActiveCell,
LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False).Activate
If Err.Number <> 91 And Err.Number <> 0 Then
MsgBox "Unresolved Error"
Exit Sub
End If
If ActiveCell.Row > 1 Then
Set myRange = Range("I1").Resize(Range( _
"I" & Rows.Count).End(xlUp).Row, 1)
For Each cell In myRange
If cell.Value <> SAVESTR Then
If delRange Is Nothing Then
Set delRange = cell
Else
Set delRange = Union(delRange, cell)
End If
End If
Next cell
If Not delRange Is Nothing Then delRange.EntireRow.Delete
Range("B1").Select
Selection.EntireRow.Insert
Else
Columns("A:A").ColumnWidth = 2
End If
Application.ScreenUpdating = False
End Sub
'Any And all suggestions will be appreciated.