Сбор данных из разных файлов в один - VBA

Формулировка задачи:

Добрый день. Стоит задача собирать данные из нескольких файлов с одинаковой структурой в один, имеющий аналогичную структуру. Имена файлов имеют одинаковое правило - 2016_07_ОП_*наименование*, то есть год, месяц, ОП-название формы, далее идет наименование отдела. Собирать данные нужно с конкретного листа и вставлять в файл на лист, с таким же наименованием (именовать лист нужно автоматически). Так же в сборочный файл нужно добавить две колонки - Год и Месяц. Брать данные для их заполнения нужно из имен файлов, то есть в данном случае всем скопированным строкам нужно поставить год - 2016 и месяц - 07. Есть вот такой макрос, найденный на этом форуме (Извините за неудобства. Вставляю со всеми отступами, но они почему-то пропадают):

                    Листинг программы
                
 
                            
                        
Sub Собрать_данные_из_xlsx_файлов()
    ' Макрос создает книгу и последовательно вставляет на одноименные листы
    ' данные из всех xls файлов заданной директории начиная со строки FRow.
    Const FRow& = 2                ' Номер строки начала сбора данных (ниже шапки)
    Const Sborka$ = "Сборка.xlsx"   ' Имя сборочного файла
    Dim FCol&, LCol&               ' Переменные номеров первого и последнего столбца для сбора данных
    Dim LRow&, LRow_Cel&
    Dim wb_Cel As Workbook, wb_Tek As Workbook
    Dim Sh_Cel As Worksheet, Sh_Tek As Worksheet
    Dim MyPath$, MyFileName$, MyFulName$
    Dim Uslovie1 As Boolean
    
    ' Выбор папки
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку": .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        MyPath = .SelectedItems(1) & ""
    End With
    
    'MyPath = "C:\inbox\???? ???????\????"
    ' MyPath = CurDir & ""
    MyFileName = Dir(MyPath & "*.xls*")
    Uslovie1 = False
    Do Until MyFileName = ""
        If MyFileName <> Sborka Then
            MyFulName = MyPath & MyFileName
            Workbooks.Open Filename:=MyFulName, UpdateLinks:=0
            If Not Uslovie1 Then
                Set wb_Cel = ActiveWorkbook
                ActiveWorkbook.SaveAs Filename:=MyPath & Sborka, FileFormat:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
                Uslovie1 = True
            Else
                Set wb_Tek = ActiveWorkbook
                For Each Sh_Cel In wb_Cel.Sheets
                    With Sh_Cel
                        FCol = .UsedRange.Cells(1, 1).Column
                        LCol = .UsedRange.Columns.Count + FCol - 1
                        LRow_Cel = .Cells(.Rows.Count, FCol).End(xlUp).Row + 1
                    End With
                    For Each Sh_Tek In wb_Tek.Sheets
                        If Sh_Tek.Name = Sh_Cel.Name Then
                            With Sh_Tek
                                LRow = .Cells(.Rows.Count, FCol).End(xlUp).Row
                                If LRow >= FRow Then
                                    .Range(.Cells(FRow, FCol), .Cells(LRow, LCol)).Copy Sh_Cel.Cells(LRow_Cel, 1)
                                End If
                            End With
                        End If
                    Next Sh_Tek
                Next Sh_Cel
                Workbooks(MyFileName).Close SaveChanges:=False
            End If
        End If
        MyFileName = Dir
    Loop
End Sub

Но этот макрос копирует все листы. Помогите, пожалуйста, его поправить под необходимый мне функционал. Спасибо.

Решение задачи: «Сбор данных из разных файлов в один»

textual
                            Листинг программы 
                        
 
                            
                        
Sub Собрать_данные_Бюджетов()
    ' Макрос собирает в новой книге данные из заданного листа  xls файлов с нужным шаблоном имени выбранной папки.
    Const ImyaListaSbora = "Бюджет расходов и платежей"
    Const FirstRow_Cel& = 2          ' Номер строки начала построения
    Const FirstRow& = 2              ' Номер строки начала сбора данных (ниже шапки)
    Dim i&, j&, k&, LastRow&, Gog, Mes, Metka$, A
    Dim ShCel As Worksheet, Sh As Worksheet, wb_Tek As Workbook
    Dim MyPath$, MyFileName$, MyFullName$
    k = FirstRow_Cel - 1
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Укажите рабочую папку": .Show
        If .SelectedItems.Count = 0 Then Exit Sub
        MyPath = .SelectedItems(1) & ""
    End With
    If Right$(MyPath, 1) <> "" Then MyPath = MyPath & ""
    Set ShCel = ActiveWorkbook.Worksheets(ImyaListaSbora)
    i = InStr(1, ActiveWorkbook.Name, ".xls", vbTextCompare)
    If i > 0 Then Metka = Mid(ActiveWorkbook.Name, 9, i - 9)
    'ShCel.Name = ImyaListaSbora
    ShCel.UsedRange.Offset(FirstRow_Cel - 1, 0).Clear
    MyFileName = Dir(MyPath & "????_??_*_*.xls*")
    Do Until MyFileName = ""
        Gog = Left(MyFileName, 4)
        Mes = Mid(MyFileName, 6, 2)
        MyFullName = MyPath & MyFileName
        Set wb_Tek = Workbooks.Open(FileName:=MyFullName, UpdateLinks:=0, ReadOnly:=True)
        With wb_Tek.Worksheets(ImyaListaSbora)
            .AutoFilterMode = False
            LastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
            A = Range(.Cells(FirstRow, 1), .Cells(LastRow, 11)).FormulaR1C1
            For i = 1 To UBound(A)
                If A(i, 1) = Metka Then
                    k = k + 1
                    With ShCel
                        For j = 1 To 11
                            .Cells(k, j).FormulaR1C1 = A(i, j)
                        Next
                        .Cells(k, 12) = Gog
                        .Cells(k, 13) = Mes
                    End With
                End If
            Next i
        End With
        wb_Tek.Close SaveChanges:=False
        MyFileName = Dir
    Loop
    With ShCel
        .[L1] = "Год"
        .[m1] = "Месяц"
        .Range("A1:M" & k).Borders.LineStyle = xlContinuous
        .Cells(k, 1).Select
    End With
End Sub