a problem with pop up list box

[bido]

Good morning everybody
the following code is expected to search the identity number of the employee in active sheet and returns the whole row into a pop up list box (from A to R) while selecting the same row in active sheet at the same time . However, it brings nothing but sometimes the entire identity number of the employee and some times not. I've attached the code with a screen shoot of the results.
Many thanks

Private Sub TextBox1_Change()

Dim searchValue As String
Dim ws As Worksheet
Dim lr As Long
Dim i As Long
Dim filteredList As New Collection
Dim currentItem As Variant
Dim listArray() As Variant
Dim tempArray() As Variant
Dim j As Integer
Dim currentChar As String

searchValue = TextBox1.Value


If Len(searchValue) < 14 Then
    Exit Sub
End If


For Each ws In ThisWorkbook.Worksheets
    With ws
        lr = .Cells(Rows.Count, 4).End(xlUp).Row
        For i = 2 To lr
            If .Cells(i, 4).Value Like searchValue & "*" Then
              
                filteredList.Add .Cells(i, 4).Value & "|" & i & "|" & .Name
            End If
        Next i
    End With
Next ws


ReDim listArray(filteredList.Count - 1)
For i = 1 To filteredList.Count
    
    j = 0
    ReDim tempArray(1 To filteredList.Count, 1 To 3)
    For Each currentItem In filteredList
        currentChar = Left(currentItem, Len(searchValue))
        If currentChar = searchValue Then
            j = j + 1
            tempArray(j, 1) = Split(currentItem, "|")(0)
            tempArray(j, 2) = Split(currentItem, "|")(1)
            tempArray(j, 3) = Split(currentItem, "|")(2)
            
            If j = 1 And Len(searchValue) > 0 Then
                Dim foundRange As Range
                Set foundRange = Nothing
                On Error Resume Next
                Set foundRange = Sheets(tempArray(j, 3)).Cells(tempArray(j, 2), 4).EntireRow
                On Error GoTo 0
                If Not foundRange Is Nothing Then
                    foundRange.Select
                End If
            End If
        End If
    Next currentItem
    ReDim Preserve tempArray(1 To j, 1 To 3)
    listArray = tempArray
    
 
    ListBox1.Clear
    For j = 1 To UBound(listArray, 1)
        ListBox1.AddItem listArray(j, 1)
    Next j
Next i

End Sub