Sub ertert()
Dim Fold As String, f As String, wsh As Worksheet
Application.ScreenUpdating = False

Set wsh = ThisWorkbook.Sheets("Data")
With wsh.Range("A1").CurrentRegion
    If .Rows.Count > 1 Then .Offset(1).ClearContents
End With
Fold = ThisWorkbook.Path
If Right(Fold, 1) <> "\" Then Fold = Fold & "\"
f = Dir(Fold & "*.xls*", vbNormal)

Do While f <> ""
    If f <> ThisWorkbook.Name Then
        With Workbooks.Open(Fold & f)
            With .Sheets(1).Range("A1").CurrentRegion
                With .Offset(1).Resize(.Rows.Count - 1)
                    Union(.Columns(1).Resize(, 5), .Columns(7)).Copy wsh.Cells(Rows.Count, 5).End(xlUp)(2, -3)
                End With
            End With
            .Close False
        End With
    End If
    f = Dir()
Loop

Application.ScreenUpdating = True
End Sub

.Unprotect Password:="Пароль"

.protect Password:="Пароль"