Find N, leave blank and move down

[sasa]

Hi All,

This macro delete the cell containing the word in a cell and shift the rest of that column up.
[VBA]Sub Find_N_MoveUp()
Dim rFind As Range
Dim rValue As String
Dim rFound As Range
Dim rRange As Range
Dim strFirstAddress As String

Set rRange = ActiveSheet.UsedRange
rValue = InputBox("Enter value to find", "Find all occurences")
With rRange
Set rFind = .Find(rValue, LookIn:=xlValues, lookat:=xlWhole)
If Not rFind Is Nothing Then
strFirstAddress = rFind.Address
Set rFound = rFind
Do
Set rFound = Union(rFound, rFind)
Set rFind = .FindNext(rFind)
Loop While Not rFind Is Nothing And rFind.Address <> strFirstAddress
End If
End With

If Not rFound Is Nothing Then
rFound.Delete Shift:=xlUp
End If[/VBA]
I am wondering if it is possible to modify this macro the way it delete the cell containing the word but leave blank that cell and shift the rest of that column down.

Thanks in advance

Sasa

[GarysStudent]

This version will only Clear and not delete:

[VBA]Sub Find_N_MoveUp()
Dim rFind As Range
Dim rValue As String
Dim rFound As Range
Dim rRange As Range
Dim strFirstAddress As String

Set rRange = ActiveSheet.UsedRange
rValue = InputBox("Enter value to find", "Find all occurences")
With rRange
Set rFind = .Find(rValue, LookIn:=xlValues, lookat:=xlWhole)
If Not rFind Is Nothing Then
strFirstAddress = rFind.Address
Set rFound = rFind
Do
Set rFound = Union(rFound, rFind)
Set rFind = .FindNext(rFind)
Loop While Not rFind Is Nothing And rFind.Address <> strFirstAddress
End If
End With

If Not rFound Is Nothing Then
rFound.Clear
End If
End Sub
[/VBA]

This version will Clear and push down:

[VBA]Sub Find_N_MoveUp()
Dim rFind As Range
Dim rValue As String
Dim rFound As Range
Dim rRange As Range
Dim strFirstAddress As String

Set rRange = ActiveSheet.UsedRange
rValue = InputBox("Enter value to find", "Find all occurences")
With rRange
Set rFind = .Find(rValue, LookIn:=xlValues, lookat:=xlWhole)
If Not rFind Is Nothing Then
strFirstAddress = rFind.Address
Set rFound = rFind
Do
Set rFound = Union(rFound, rFind)
Set rFind = .FindNext(rFind)
Loop While Not rFind Is Nothing And rFind.Address <> strFirstAddress
End If
End With

If Not rFound Is Nothing Then
rFound.Clear
rFound.Insert Shift:=xlDown
End If
End Sub
[/VBA]

[sasa]

thanks in advance, but what is cleared has to copy down as well. Any help ?

Sasa