Find specific value in a cell, select the cell and copy all cells beneath

I have been trying to get this to work. I thought I was going in the right direction, but it's not working for me.

I want the macro to find a cell containing a specific text. Once that cell is found, I want all cells beneath it that contain a non blank to be copied.

Any help would be appreciated.

Sub test2()
    Dim MyRange As Range
                Set MyRange = Cells.Find(What:="Shortage", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate


    Range(MyRange, Range(MyRange).End(xlDown)).Copy
    Sheets("Item List").Select
    Range("R2").Select
    ActiveSheet.Paste


End Sub