Macro in excel to copy specific values from a table with a specific criteria

I want to make a macro in excel that makes the following steps:

1. Search a specific String in a specific column ("D")
2. Copy some values from specific columns of that table, which have the specific string (I had searched in step 1) in the column D, to another worksheet.

So in order to do this I have:

Sub MyMacro()
Dim rngSearch As Range, rngFound As Range
'Ask for the string I want to find
site_name = InputBox(prompt:="Please enter site name:")

Set rngSearch = Range("D:D")
Set rngFound = rngSearch.Find(What:=site_name, LookIn:=xlValues, LookAt:=xlPart)
If rngFound Is Nothing Then
MsgBox "Not found"
Else
.
.
.
End If

Now I'm not sure how to manipulate the range variable I got from the search. How can I say for example, regarding the table bellow, that I want to copy the values from the "Country" and Population columns that corresponds to the "Lisbon" value in the city column to another worksheet ?

ptINZ.jpg

Thanks in advance

Hi Berlan,

Thanks for the tip. I've some doubts on your code though. In the last part, why do you do the Intersect stuff? I adapted the code to my files and became something like the code bellow where I want to paste the information in a another workbook begining in the Cell A15. When I run the macro it gives me a warning box saying "Run Time Error '9': Subscript out of range"

Sub test()

    Dim r As Range, rngOut As Range
    Dim sAdr As String, sSite As String

    sSite = InputBox("Please enter site name:")

    With Workbooks("original_excel.xls").Sheets("original_sheet").Columns("D")
        
        'loop and find all matching
        Set r = .Find(sSite, , xlValues, xlWhole)     'change xlPart to xlWhole for exact match
        If Not r Is Nothing Then
            sAdr = r.Address 
            Do
                If rngOut Is Nothing Then Set rngOut = r Else Set rngOut = Union(r, rngOut)
                Set r = .FindNext(r)
            Loop While r.Address <> sAdr
        End If

        If Not rngOut Is Nothing Then
      Intersect(.Parent.Range("A:D"), rngOut.EntireRow).Copy
                    Workbooks("destination_excel.xls").Sheets("Sheet1").CELL ("A15")
            
        End If

    End With

End Sub

I had tried also replace the Itersect part for something more basic like the code bellow but it also failed giving me the same message

rngOut.EntireRow.Copy
Workbooks("Data.xls").Sheets("Sheet1").CELL("A15").PasteSpecial

Can you help me again?

Thanks

Hi again Berlan,

I solve that problem with minor changes. End up with the final code bellow (just changed the Intersect part). Just one more question, If I want to copy another column beside the ones comprised by the A:D range i.e if I want to copy the A:D range plus the Z column how can I do the intersection?

Once again, thanks for the help =)

Intersect(.Parent.Range("A:D"), rngOut.EntireRow).Copy
Workbooks("destination_excel.xlsx").Sheets("Sheet1").Range("A15").PasteSpecial (xlPasteValues)