Agfdhyk

All-

I'm very new to VBA and I really need help. I have a worksheet called Sheet 1 that looks like this (This is where the data will be copied from)

and another sheet (Sheet2) that looks like this (this is where the data will be copied to). Notice that the order is not the same as above

When a user types in a place such as "Paris" I want it to copy all corresponding values with "Paris" and it's associated rows. So the end result should look like this

Here is the code I have so far. Right now I can pull all the corresponding values based on the Users input, but I cannot for the life of me figure out how to get the associated rows. Please help! Any input will be highly appreciated.

Dim x As String

Dim K As Long

Dim ct As Variant

Dim r As Range

Dim w1 As Worksheet

Dim w2 As Worksheet

Set w1 = Sheets("Sheet1")

Set w2 = Sheets("Sheet2")

a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row

x = Application.InputBox("Please Enter Place")

w1.Activate

K = 3

For Each r In Intersect(Range("C3:C3" & a), ActiveSheet.UsedRange)

ct = r.Value

If InStr(ct, x) > 0 And ct <> "" Then

r.Copy w2.Cells(K, 1)

K = K + 1

w2.Activate

End If

Next r

End Sub

Assign the entire range to an array for quicker looping, then once the array finds a match to your inputstring, rewrite the values to your 2nd sheet.

Sub test()



    Dim ws1 As Worksheet, ws2 As Worksheet, wsArr()

    set ws1 = thisworkbook.worksheets("Sheet1")

    set ws2 = thisworkbook.worksheets("Sheet2")



    With ws1

        wsArr = .Range(.Cells(3, 1), .Cells(LastRow(ws1), 4)).Value

    End With



    Dim findStr As String

    findStr = InputBox("Please Enter Place")



    Dim i As Long, r as long

    Application.ScreenUpdating = False

    With ws2

        .Range("A3:D3").Value = array("Place", "Name", "Thing", "Animal")

        For i = LBound(wsArr) To UBound(wsArr)

            If wsArr(i, 3) = findStr Then

                r = LastRow(ws2) + 1

                .Cells(r, 1) = wsArr(i, 3)

                .Cells(r, 2) = wsArr(i, 1)

                .Cells(r, 3) = wsArr(i, 2)

                .Cells(r, 4) = wsArr(i, 4)

            End If

        Next

    End With

    Application.ScreenUpdating = True



End Sub



Function LastRow(ByVal ws As Worksheet, Optional ByVal col As Variant = 1) As Long

    With ws

        LastRow = .Cells(.Rows.Count, col).End(xlUp).Row

    End With

End Function

For even better performance, consider doing a COUNTIF() to get the count of the number of findStr occurances in your range - that way you can use this value to ReDim a new array in order to write the matches there, then write the array to Sheet2 all at once.