Moin,

einfacher und besser steuerbar wäre, wenn die gesammte "Such&Find" Aktion über Zell-Bereiche zugeordnet würde, dennoch einmal so als Ansatz

Option Explicit

Sub Ordnung()
Dim x As Integer
Dim y As Integer
Dim intx As Integer
Dim inty As Integer
Dim rngWert As Range

'plausi - alles hängt an der 7
If Cells(3, 8).Value < 1 Then Exit Sub

On Error GoTo fail
   intx = Cells(3, 8).Value + 6  'Endwert
   'plausi
   If intx > Cells(Cells.Rows.Count, 7).End(xlUp).Row Then Exit Sub
   
   For x = 7 To intx
      Set rngWert = Cells(x, 8).Offset(-1)   'vorhergehende Zelle!
      Cells(x, 8).Value = Application.WorksheetFunction.VLookup(Cells(x, 7), _
      Range(Cells(4, 1), Cells(Cells.Rows.Count, 2).End(xlUp)), 2, False)
   Next x


   inty = Cells(3, 8).Value + 6  'Endwert
   'plausi
   If inty > Cells(Cells.Rows.Count, 7).End(xlUp).Row Then Exit Sub
   
   For y = 7 To inty
      Set rngWert = Cells(y, 9).Offset(-1)
      Cells(y, 9).Value = Application.WorksheetFunction.VLookup(Cells(y, 7), _
      Range(Cells(4, 4), Cells(Cells.Rows.Count, 5).End(xlUp)), 2, False)
   Next y
On Error GoTo 0
fail:
Select Case Err.Number
   Case 0
      'na und?
   Case 1004
      'VLookup Fehler angenommen
      Select Case rngWert.Column
         Case 8
            Select Case rngWert.Row + 1
               Case 7
                  If intx > 7 Then
                     x = x + 1
                     Resume
                  End If
               Case 8 To intx
                  Cells(x, 8).Value = rngWert.Value
                  x = x + 1
                  Resume
            End Select
         Case 9
            Select Case rngWert.Row + 1
               Case 7
                  If inty > 7 Then
                     y = y + 1
                     Resume
                  End If
               Case 8 To inty
                  Cells(y, 9).Value = rngWert.Value
                  y = y + 1
                  Resume
            End Select
      End Select
End Select
End Sub