Search and Find Macro runs too slow

Hello All!

So I wrote the following code to run on a button click. Essentially, I want to to loop through a column of data until the end. For each cell that has data it will search for a match in another column on another worksheet. If a match is found various cells adjacent to it are copied and brought back to the first worksheet and pasted alongside the original cell.

I got all of this working fine, however, it takes too long to run. I have a list of over 2000 items, and after running for 2 minutes the code only got through 200 lines. Can you help me speed it up at all?

Sub Loop_All()
Dim x
Dim y As Worksheet
Dim founddata As Range
Do Until IsEmpty(ActiveCell.Value)

x = ActiveCell.Value
Set y = ActiveSheet
Set founddata = Worksheets("Data Archive").Cells.Find(what:=x, LookIn:=xlValues)
Application.ScreenUpdating = False
Worksheets("Data Archive").Select
Range([A1], [A:A].Find("*", [A1], , , xlByRows, xlPrevious)).Select
If founddata Is Nothing Then
    ActiveCell.Offset(1, 0).Select
Else: founddata.Activate
    ActiveCell.Offset(0, 1).Resize(1, 4).Copy
    y.Select
    ActiveCell.Offset(0, -4).PasteSpecial
ActiveCell.Offset(0, 13).Select
    ActiveCell.Value = Date
ActiveCell.Offset(1, -9).Select
End If
    
Loop
Application.ScreenUpdating = True
Exit Sub


End Sub