Option Explicit

Sub собрать_таблицы()
    Dim wb As Workbook
    Dim wbi, per$, est
    Dim pt0, pat, fil, nt, cn, ck, kt, rx As Range
    Set wb = ActiveWorkbook
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    pt0 = ActiveWorkbook.Path
    fil = Dir(pt0 & "\*.xls*")
    Do While Len(fil) > 0
        Debug.Print fil
        If fil <> wb.Name Then
            Set wbi = Workbooks.Open(pt0 & "\" & fil).Worksheets(1)
            With wbi
                Set rx = .Cells.Find("Обороты для главной книги")
                If Not rx Is Nothing Then
                    nt = rx.Row
                    cn = rx.Column
                    ck = cn + rx.MergeArea.Count - 1
                    Set rx = .Cells.Find("итого по журналу операций")
                    If Not rx Is Nothing Then
                       kt = rx.Row
                       per = .[f3]
                        est = ЛИСТСУЩ(per)
                        If est Then
                            MsgBox "Дубль периода " & per, vbCritical, ""
                        Else
                            With wb.Worksheets.Add
                    .Name = per
                    wbi.Cells(nt, cn).Resize(kt - nt + 1, ck - cn + 1).Copy wb.Worksheets(per).Cells(1, 1)
                            End With
                        End If
                    End If
                
                End If
            End With
      
            wbi.Parent.Close
        End If
    fil = Dir()
    Loop
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Function ЛИСТСУЩ(ИМЯ As String) As Boolean
    Dim Sh As Object
    On Error Resume Next
    Set Sh = ActiveWorkbook.Sheets(ИМЯ)
    If Err.Number = 0 Then ЛИСТСУЩ = True
End Function