Public Sub ImportText()
Dim this As Worksheet
Dim txtFile As Workbook
Dim cell As Range
Dim firstaddress As String
Dim nextrow As Long

    Set this = ActiveSheet
    nextrow = 6
    
    With Application.FileDialog(msoFileDialogOpen)
    
        .AllowMultiSelect = False
        .InitialFileName = "File.txt"
        If .Show = -1 Then
        
            Workbooks.OpenText Filename:=.SelectedItems(1), _
                                             DataType:=xlDelimited, _
                                             Tab:=True
                                             
            With ActiveWorkbook
            
                With .Worksheets(1).Columns(1)
            
                    Set cell = .Find("Polisnummer", LookIn:=xlValues)
                    If Not cell Is Nothing Then
                    
                        firstaddress = cell.Address
                        Do
                        
                            this.Cells(nextrow, "B").Value = Trim(Replace(cell.Value, "Polisnummer", ""))
                            this.Cells(nextrow, "C").Value = Trim(Replace(cell.Offset(2, 0).Value, "Attribuut", ""))
                            this.Cells(nextrow, "D").Value = Trim(Replace(cell.Offset(3, 0).Value, "Waarde", ""))
                            this.Cells(nextrow, "E").Value = Trim(Replace(cell.Offset(4, 0).Value, "Foutmelding", ""))
                            
                            Set cell = .FindNext(cell)
                            nextrow = nextrow + 1
                        Loop While Not cell Is Nothing And cell.Address <> firstaddress
                        
                    End If
                End With
                
                .Close SaveChanges:=False
            End With
        End If
    End With
End Sub