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.