VBA søgning efter værdier i projektmappe

Her rettet så den tager cellen under det fundne.
Håber du selv kan overskue resten

Sub FindOrd()
Dim Fundet(100, 5) As String, Sted(100) As String, Søg As Variant, I As Integer, T As Integer
Dim R As Integer
I = 1
On Error Resume Next
Sheets("Forside").Select
  Range("B2:H201").Select            ' sletter alle data i området til hyperlink
    Selection.ClearContents
    Range("a2").Select
    Søg = InputBox("Skriv søgestrengen på hvad der skal Findes", "Find medicinske præparater")
Application.ScreenUpdating = False
    For Each ws In Worksheets
If ws.Name <> "Forside" Then ' skift selv navnet på forsiden
      Sheets(ws.Name).Select
      Range("A1:A500").Select 'området den søger på ret det selv til
      Selection.Find(What:=Søg, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False).Activate
        If Error = 91 Then
        Err.Clear
        If I > 1 Then I = I - 1
        GoTo Videre
        End If
        a = ActiveCell.Row
        If a = 1 Then GoTo Videre
        b = ActiveCell.Column
        Cells(a, b).Activate
        Sted(I) = ws.Name & "!" & ActiveCell.Address
        For T = 1 To 5 'Læser 5 celler per række
        Fundet(I, T) = Sheets(ws.Name).Cells(a, T).Offset(1, 0).Value ' RETTET
        Next
          If I > 1 Then
        For T = 1 To I - 1
          If Sted(I) = Sted(T) Then
          GoTo Videre
        End If
        Next
      End If
      I = I + 1
    Do
      Cells.FindNext(After:=ActiveCell).Activate
        If Error = 91 Then
        Err.Clear
        If I > 1 Then I = I - 1
        GoTo Videre
        End If
        a = ActiveCell.Row
          If a = 1 Then GoTo Videre
        b = ActiveCell.Column
        Cells(a, b).Activate
        Sted(I) = ws.Name & "!" & ActiveCell.Address
        For T = 1 To 5 'Læser 5 celler per række
        Fundet(I, T) = Sheets(ws.Name).Cells(a, T).Offset(1, 0).Value ' RETTET
        Next
      If I > 1 Then
        For T = 1 To I - 1
        If Sted(I) = Sted(T) Then
                GoTo Videre
          End If
        Next
      End If
      I = I + 1
  Loop
End If
Videre:
Next
Slut:
  Sheets("Forside").Select
  Application.ScreenUpdating = True
  For T = 1 To I - 1
    Worksheets("Forside").Range("B2:F101").Cells(T, 1).Select
    For R = 1 To 5
      ActiveCell.Offset(0, R) = Fundet(T, R)
      ActiveCell = Sted(T)
      Next
      Next
      If I = 1 Then
      MsgBox " ingen fundet"
      End If
End Sub

Det ser godt ud... jeg takker, så hvis du smider et svar så skal jeg acceptere :-)

et svar ;-))