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