VBA to find value anc create entire row

Good day to all.

I need a macro that will search a value in column D (sheet2) that is noted in cell C7 on sheet3.
Afterthat it must copy enitre entire row where searched value was found to sheet3, last empty row.

an example:

entered value in cell C7 on sheet 3 is ABC
on Sheet2 column D, value ABC was found in cell 150 (D150) so it has to copy for 150 to sheet3, last empy row.

How to od it?

Thanks.

Maybe:

Sub forfiettYY()
Dim x As String
x = Sheets("Sheet3").Range("C7").Value
Sheets("Sheet2").Columns(4).Cells.Find(What:=x, After:=Cells(1, 4), LookIn:=xlFormulas, lookat:=xlPart, Searchorder:=xlByRows, searchDirection:=xlNext, MatchCase:=False).Activate
Rows(ActiveCell.Row).Copy Sheets("Sheet3").Range("A" & Rows.count).End(3)(2)
End Sub

Good day,

thanks for quick reply but is not working for me....
any other option?

Option Explicit

Sub fin()
Dim Rng As Range, x, ms As Worksheet
Set ms = Sheets("Sheet3")
x = ms.Range("C7").Value
Application.ScreenUpdating = 0
             With Sheets("Sheet2").Columns(4)
                     Set Rng = .Find(x, LookIn:=xlValues, LookAt:=xlWhole)
                        If Not Rng Is Nothing Then
                            Rng.EntireRow.Copy
                            ms.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
                        End If
             End With
     
    
     Application.CutCopyMode = 0

Set Rng = Nothing
Set ms = Nothing

Application.ScreenUpdating = True
End Sub

perfect! for now is working ..
will revert if any additional option will be needed.
THANKS

Dears,

it is possible to ammend above code that will not copy entire row but only fm colum A to M

Thanks in advance

Rng.EntireRow.Copy

INTO

Rng.Offset(, -3).Resize(, 13).Copy

Please close the thread now as solved

Normally, same values are in a sequence in a column.

fortfiett,
This thread is over a month old. If you do not close it, it will go for ever. The forum has designed in such away that a thread must be closed at some point. You can start a new thread, linking it with the old thread.
Please mark the thread as solved. If you have further questions, you should start a new thread.

Option Explicit

Sub fin()
Dim Rng As Range, x, ms As Worksheet, FirstAddress$
Set ms = Sheets("Sheet3")
x = ms.Range("C7").Value
Application.ScreenUpdating = 0
             With Sheets("Sheet2").Columns(4)
                     Set Rng = .Find(x, LookIn:=xlValues, LookAt:=xlWhole)
                        If Not Rng Is Nothing Then
                        FirstAddress = Rng.Address
                        Do
                            Rng.Offset(, -3).Resize(, 13).Copy
                            ms.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
                             Set Rng = .FindNext(Rng)
                        Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
                        End If
             End With
     
    
     Application.CutCopyMode = 0

Set Rng = Nothing
Set ms = Nothing

Application.ScreenUpdating = True
End Sub

Dear,

it was marked a solved, but i need firther assistance so i unmarked it..

thanks for code but is not working...

please check: Rng.Offset(, -3).Resize(, 13).Copy

I have got the line from post#7.

Finally it is working. Thanks.

Marked as solved.