copying row + 1 row above and copying row + 1 row below

[mokhtar]

Hi,
I have 2 code to deleting row + 1 row above and deleting row + 1 row below

Sub DeleteRowsandbove ()

On Error Resume Next
Do
ActiveSheet.Columns("A").Find("*mokhtar*", , xlValues, xlWhole).Offset(-1, 0).EntireRow.Resize(2).Delete
Loop Until Err.Number <> 0

End Sub

Sub DeleteRowsabelow ()

On Error Resume Next
Do
ActiveSheet.Columns("A").Find("*mokhtar*", , xlValues, xlWhole).Offset(0, 0).EntireRow.Resize(2).Delete
Loop Until Err.Number <> 0

End Sub

I have tried to adapt 2 macro to copying row + 1 row above and copying row + 1 row below
and paste in D1
Any help would be greatly appreciated. Thanks in advance.

[SamT]

Sub CopyAboveAndBelow()
ActiveSheet.Columns("A").Find("*mokhtar*", , xlValues, xlWhole) _
.Offset(-1).EntireRow.Resize(3, Range("A1").CurrentRegion.Columns.Count).Copy Range("D1")
End Sub

[mokhtar]

Mr sam Thanks for the reply

I'm not clear enough in my explanation,

I have 2 request :

1- in the first code i want to adapt it to :Loop in col "A" - Find the value "mokhtar" - then copying row + 1 row above - paste in D1

2- in the second i want to adapt it to :Loop in col "A" - Find the value "mokhtar" - then copying row + 1 row below - paste in D1

Thanks in advance for all your help!!

[SamT]

that does both at same time. Why do two steps?

[mokhtar]

First of all thank you for your time and effort, but again
the First request update the below code to copying row + 1 row below then paste data in D1

Sub DeleteRowsabelow ()

On Error Resume Next
Do
ActiveSheet.Columns("A").Find("*mokhtar*", , xlValues, xlWhole).Offset(0, 0).EntireRow.Resize(2).Delete
Loop Until Err.Number <> 0

End Sub

the second request update the below code to copying row + 1 row above then paste data in E1

Sub DeleteRowsandbove ()

On Error Resume Next
Do
ActiveSheet.Columns("A").Find("*mokhtar*", , xlValues, xlWhole).Offset(-1, 0).EntireRow.Resize(2).Delete
Loop Until Err.Number <> 0

End Sub





Million Thanks

[SamT]

Sub DeleteRowsabelow ()

On Error Resume Next
Do
ActiveSheet.Columns("A").Find("*mokhtar*", , xlValues, xlWhole).Offset(0, 0).EntireRow.Resize(2).copy Range("D1")
Loop Until Err.Number <> 0

End Sub


B]Sub DeleteRowsandbove ()

On Error Resume Next
Do
ActiveSheet.Columns("A").Find("*mokhtar*", , xlValues, xlWhole).Offset(-1, 0).EntireRow.Resize(2).Copy Range("D1")
Loop Until Err.Number <> 0

End Sub


[/B]

[mokhtar]

Mr sam Thank you so much for this post and your time
I tested the 2 code it doesn't work
Hope it is clear now

Many thanks in advance.