Option Explicit

Sub Merge()
    Dim i As Long, j As Long
    Dim FileNames() As String
    Dim ws          As Worksheet

    Dim Merged      As Workbook
    Set Merged = ThisWorkbook

    Dim iFolderPath As String
    iFolderPath = "C:\Новая папка"    ' Замените на ваш путь к файлам

    Dim FilePath    As String
    FilePath = Dir(iFolderPath & "\*.xlsx")

    Dim FileCount   As Long
    FileCount = 0

    Dim RowCnt      As Long
    RowCnt = 1

    ' Подсчет и сохранение путей к файлам
    Do While FilePath <> ""
        FileCount = FileCount + 1
        ReDim Preserve FileNames(1 To FileCount)
        FileNames(FileCount) = iFolderPath & "\" & FilePath
        FilePath = Dir
    Loop

    If FileCount < 1 Then
        MsgBox "No files found in the specified directory!", vbCritical
        Exit Sub
    End If

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    For i = LBound(FileNames) To UBound(FileNames)

        Dim wb      As Workbook
        Set wb = Workbooks.Open(FileNames(i), UpdateLinks:=False)

        For Each ws In wb.Worksheets

            If ws.Index = 1 Then

                ' Первая таблица: 11-я и 18-я строки
                If ws.FilterMode Then ws.ShowAllData
                Merged.Worksheets(1).Rows(RowCnt).Value = ws.Rows(11).Value
                RowCnt = RowCnt + 1

                Merged.Worksheets(1).Rows(RowCnt).Value = ws.Rows(18).Value
                RowCnt = RowCnt + 1
            ElseIf ws.Index = 2 Then

                ' Вторая таблица: 8-я, 9-я, 10-я и 11-я строки
                If ws.FilterMode Then ws.ShowAllData

                Dim LastRow As Long
                LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

                For j = 8 To Application.Min(11, LastRow)
                    Merged.Worksheets(1).Rows(RowCnt).Value = ws.Rows(j).Value
                    RowCnt = RowCnt + 1
                Next j

            End If

        Next ws

        wb.Close SaveChanges:=False
    Next i

    ' Освобождение объектов
    Set wb = Nothing
    Set Merged = Nothing

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

    MsgBox "Finished merging.", vbInformation
End Sub

Sub u_17()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    x = Cells(Rows.Count, "a").End(xlUp).Row
    Range("a1:q" & x).Clear
    a = ThisWorkbook.Path   'папка в который находиться файл
    b = Dir(a & "\*.xlsx")  'имя файла с рашрирешием xlsx
    Do While b <> ""
        c = Cells(Rows.Count, "a").End(xlUp).Row + 1
        Workbooks.Open Filename:=a & "\" & b, UpdateLinks:=False
        Workbooks(b).Sheets(1).Range("a11:q11").Copy
        ThisWorkbook.Sheets(1).Range("a" & c).PasteSpecial Paste:=xlPasteValues
        Workbooks(b).Sheets(1).Range("a18:q18").Copy
        ThisWorkbook.Sheets(1).Range("a" & c + 1).PasteSpecial Paste:=xlPasteValues
        e = Workbooks(b).Sheets(2).Cells(Rows.Count, "a").End(xlUp).Row
        Workbooks(b).Sheets(2).Range("a8:h" & e).Copy
        ThisWorkbook.Sheets(1).Range("a" & c + 2).PasteSpecial Paste:=xlPasteValues
        Workbooks(b).Close False
        b = Dir
    Loop
    Rows(1).Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

e = Workbooks(b).Sheets(2).Cells(Rows.Count, "a").End(xlUp).Row