Makro der finder en tekst og kopierer en nærtliggende celle

Skriver alle de  fundne i ark2 kolonne A, under hinanden

Sub FindOrd()
Dim Fundet() As String, OK As Boolean
I = 1
'On Error GoTo Slut
ReDim Fundet(1)
    Søg = "status - ok"
      Columns("A:H").Select 'området den søger på ret det selv til, her kolonne A til H
      Selection.Find(What:=Søg, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Activate
        A = ActiveCell.Row
        B = ActiveCell.Column
        Færdig = Cells(A, B).Address
        Cells(A, B).Activate
        Fundet(I) = ActiveCell.Address
      I = I + 1
    Do
    ReDim Preserve Fundet(I)
      Cells.FindNext(After:=ActiveCell).Activate
        A = ActiveCell.Row
        B = ActiveCell.Column
        Cells(A, B).Activate
      If Cells(A, B).Address = Færdig Then Exit Do
        Fundet(I) = ActiveCell.Address
      I = I + 1
  Loop
'Videre:

Slut:
'Ret nedenstående til dit arknavn og kolonner
  For t = 1 To I - 1
  rk = Sheets("Ark2").Range("A65536").End(xlUp).Offset(1, 0).Row
  Sheets("Ark2").Range("A" & rk) = Range(Fundet(t)).Offset(-2, 1).Value
 
     
Next

End Sub