A very small modification to get out of the infinite loop,: two lines added (see comments) the idea of this is when it detects a matching row it blanks the data in the input array so that it can't find it again. This means that I need to reload the input array after each loop


Dim str As String
Dim status As String
Dim inarr() As Variant
Dim lastrow As Integer
Dim outpt As String
Dim com As String










Sub findit()
Dim str As String


With Worksheets("Sheet1")
 lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
 inarr = Range(.Cells(1, 1), .Cells(lastrow, 3))
 
 Range(.Cells(1, 4), .Cells(lastrow, 4)) = ""
 outarr = Range(.Cells(1, 4), .Cells(lastrow, 4))
 


outpt = ""
'For jj = 2 To lastrow
For jj = 2 To 160
inarr = Range(.Cells(1, 1), .Cells(lastrow, 3))    ' line added
str = inarr(jj, 2)
status = "Next"
com = "'"
Do While status = "Next"


 Call findone(str, inarr, lastrow, status)
 com = ","
  
Loop
  outarr(jj, 1) = outpt
  outpt = ""
 Next jj
 
 Range(.Cells(1, 4), .Cells(lastrow, 4)) = outarr
 End With
 End Sub


Sub findone(str As String, inarr() As Variant, lastrow As Integer, status As String)
fnd = False
For i = 2 To lastrow
 If str = inarr(i, 2) Then
   inarr(i, 2) = ""         ' line added
   If str = inarr(i, 3) Then
    ' end of line
     
      status = "Dead end"
      fnd = True
      outpt = outpt & com & inarr(i, 1)
      Exit For
   Else
      str = inarr(i, 3)
      status = "Next"
      fnd = True
      outpt = outpt & com & inarr(i, 1)
      Exit For
   End If
 End If
Next i
If Not (fnd) Then
 status = "Not found"
End If
End Sub