Sub Report()
Dim FoundPropusk As Range
Dim FAdr As String
    Set FoundPropusk = Columns(1).Find("Отсканирован пропуск ", , xlValues, xlPart)
     If Not FoundPropusk Is Nothing Then
      FAdr = FoundPropusk.Address
      Do
         Cells(FoundPropusk.Row, 6) = Split(FoundPropusk, "Отсканирован пропуск ")(1)
       Set FoundPropusk = Columns(1).Find("Отсканирован пропуск ", After:=FoundPropusk)
      Loop While FoundPropusk.Address <> FAdr
     End If
End Sub

Sub replacement()
    Columns("A:A").Select
      Selection.Replace What:=".", replacement:=",", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End Sub

OOption Explicit

Public Sub processF()
    Dim str1 As String, strPass As String
    Dim arr1(1 To 200) As Double
    Dim curIndex As Byte
    Dim fileToOpen, arr2
    Dim flagMass As Boolean, flgout As Boolean
    Dim arrStr(1 To 3) As String
    Dim rowCur As Long, i&
    
    arrStr(1) = "*Текущий вес*"
    arrStr(2) = "*Зарегистрированный вес*"
    arrStr(3) = "*Отсканирован пропуск*"
    rowCur = 1
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Выбрать файл" 'заголовок окна диалога
        .Filters.Clear 'очищаем установленные ранее типы файлов
        .Filters.Add "Text files", "*.log", 1 'добавляем возможность выбора текстовых log файлов
        .FilterIndex = 1 'устанавливаем тип файлов по умолчанию
        .InitialFileName = ThisWorkbook.Path & "\" 'назначаем папку отображения и имя файла по умолчанию
        .InitialView = msoFileDialogViewDetails 'вид диалогового окна(доступно 9 вариантов)If fileToOpen = False Then Exit Sub
        If .Show = False Then Exit Sub: If .SelectedItems.Count = 0 Then Exit Sub
        fileToOpen = .SelectedItems(1)
        Open fileToOpen For Input As #1
    End With
    Worksheets("out").UsedRange.ClearContents
    Do Until flgout
        On Error Resume Next
        Line Input #1, str1
        If EOF(1) Then str1 = ""
        On Error GoTo 0
        If str1 Like arrStr(2) Then
            arr2 = Split(str1, " ")
            If Val(arr2(UBound(arr2))) < 45 Then
                Do Until str1 = "" Or EOF(1)
                    Line Input #1, str1
                Loop
                Erase arr1
                curIndex = 0
                strPass = ""
                flagMass = False
            Else
                flagMass = True
                
            End If
            ElseIf str1 Like arrStr(3) Then
            arr2 = Split(str1, " ")
            strPass = arr2(UBound(arr2))
            strPass = Replace(strPass, Chr(34), "")
            ElseIf str1 Like arrStr(1) Then
            curIndex = curIndex + 1
            arr2 = Split(str1, " ")
            arr1(curIndex) = Val(arr2(UBound(arr2)))
            ElseIf str1 = "" Then
            If flagMass Then
                For i = 2 To curIndex
                    If Abs(arr1(i) - arr1(i - 1)) > 9 Then
                        Worksheets("out").Cells(rowCur, 1).Value = strPass
                        rowCur = rowCur + 1
                        Exit For
                    End If
                Next i
            End If
            Erase arr1
            flagMass = False
            curIndex = 0
            strPass = ""
            If EOF(1) Then flgout = True
            
        End If
    Loop
    Close #1
End Sub