PDA

View Full Version : copying row + 1 row above and copying row + 1 row below



mokhtar
06-28-2015, 06:31 AM
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
06-28-2015, 07:47 AM
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
06-28-2015, 09:10 AM
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
06-28-2015, 09:30 AM
that does both at same time. Why do two steps?

mokhtar
06-28-2015, 11:39 AM
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
06-28-2015, 12:09 PM
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
06-28-2015, 01:18 PM
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.