Dim fPath$
Dim spPath, spName
Dim A()
Dim i&, x
With Application.FileDialog(msoFileDialogFilePicker)
     .Filters.Clear
     .Filters.Add "Microsoft Excel files", "*.xls"
     .AllowMultiSelect = True
.InitialFileName = ThisWorkbook.Path
If .Show = 0 Then Exit Sub
For x = 1 To .SelectedItems.Count
  
  fPath = .SelectedItems(x)
  spPath = Split(Replace(fPath, ".xls", ""), "\")
  spName = Split(spPath(UBound(spPath)), "_")
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Workbooks.Open fPath
  
  With ActiveWorkbook
        With .ActiveSheet
            A = .Range("B3:D60" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
        End With
        .Close False
    End With
    
    With Sheets("Перечень")
        lr = .Cells(Rows.Count, 2).End(xlUp).Row + 1
        For i = 1 To UBound(A)
            If A(i, 1) <> "" Then
                '.Cells(lr, 1) = spName(0) 'номер
                '.Cells(lr, 2) = Replace(spName(2), ".xls", "") 'фамилия
                .Cells(lr, 2) = A(i, 1) 'Номер
                .Cells(lr, 4) = A(i, 3) 'Кол-во
                lr = lr + 1
     End If
    Next
  End With
             
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub