[Tasos]

Καλησπέρα Σωτήρη!
Αντικατέστησε τη ρουτίνα InsertListRow() με τον παρακάτω κώδικα:

Private Sub InsertListRow()
    Dim c As Range, hLink As Excel.Hyperlink, strHLink As String
    If Me.ListBox1.ListCount = 0 Then Exit Sub
    If Me.ListBox1.ListIndex = -1 Then Exit Sub
    Set c = Range("OrderCodes").Find(Me.ListBox1.Value, LookIn:=xlValues)
    If Not c Is Nothing Then GoTo ExitHere
    With Cells(Rows.Count, Range("OrderCodes").Column).End(xlUp).Offset(1)
        .Value = Me.ListBox1.Value
        Set c = ShData.Range("C:C").Find(.Value, LookIn:=xlValues).Offset(, 4)
        If c.Hyperlinks.Count Then
            Set hLink = c.Hyperlinks(1)
            Set c = Cells(.Row, 9)
            c.Hyperlinks.Add c, hLink.Address, , hLink.TextToDisplay, hLink.TextToDisplay
        ElseIf c.Value <> vbNullString Then
            strHLink = c.Value
            Set c = Cells(.Row, 9)
            c.Hyperlinks.Add c, strHLink, , strHLink, strHLink
        End If
        Cells(.Row, 8).Select
        If Me.ChckFocusAfterNewEntry Then
            AppActivate Application.Caption
        End If
    End With
ExitHere:
    With Me.ListBox1
        If .List(.ListIndex, 2) = ItmIsMissing Then
            .List(.ListIndex, 2) = ItmExists
        End If
    End With
    If Not c Is Nothing Then
        Cells(c.Row, 8).Select
    End If
End Sub

Καλή συνέχεια!

Τάσος