Добавление данных из одной книги Excel в другую

Sub Добавить_данные_из_xls_файлов()
    Const FRow& = 2                ' Номер строки начала сбора данных (ниже шапки)
    Const prefix$ = "Данные_"       ' Левая часть шаблона имени собираемых файлов, до номера
    Dim Shablon$
    Shablon = prefix & "*.xls*"   ' Шаблон имени собираемых файлов, где ?? позиция двузначного номера
    Dim i&, j&
    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$, CurShName$
    Dim Uslovie1 As Boolean, dicShNames As Object
    Set wb_Cel = ActiveWorkbook
    Set dicShNames = CreateObject("Scripting.Dictionary")
    For i = 1 To Worksheets.Count
        dicShNames.Item(Worksheets(i).Name) = i
    Next i
    MyPath = "C:\temp4\"
'   ' MyPath = CurDir & "\"
'    ' Выбор папки
'    With Application.FileDialog(msoFileDialogFolderPicker)
'        .Title = "Укажите рабочую папку": .Show
'        If .SelectedItems.Count = 0 Then Exit Sub
'        MyPath = .SelectedItems(1) & "\"
'    End With
    MyFileName = Dir(MyPath & Shablon)
    Uslovie1 = False
    Do Until MyFileName = ""
        If MyFileName <> wb_Cel.Name Then
            MyFulName = MyPath & MyFileName
            Set wb_Tek = GetObject(MyFulName)
            i = InStr(1, MyFileName, ".xl")
            j = Len(prefix) + 1
            i = Val(Mid$(MyFileName, j, i - j + 1))
            CurShName = "3." & Format$(i)
            If dicShNames.Exists(CurShName) Then
                With wb_Cel.Worksheets(CurShName)
                    FCol = .UsedRange.Cells(1, 1).Column
                    LCol = .UsedRange.Columns.Count + FCol - 1
                    LRow_Cel = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).row
                End With
                With wb_Tek.Worksheets(1)
                    LRow = .UsedRange.Rows.Count + .UsedRange.Cells(1, 1).row - 1
                    If LRow >= FRow Then
                        .Range(.Cells(FRow, FCol), .Cells(LRow, LCol)).Copy wb_Cel.Worksheets(CurShName).Cells(LRow_Cel, 1)
                    End If
                End With
            Else
                dicShNames.Item(CurShName) = i
                With wb_Cel
                    wb_Tek.Worksheets(1).Copy After:=.Worksheets(.Worksheets.Count)
                    .Worksheets(.Worksheets.Count).Name = CurShName
                End With
            End If
            Workbooks(MyFileName).Close SaveChanges:=False
        End If
        MyFileName = Dir
    Loop
End Sub

Set objChart = Charts.Add
With objChart
    .SetSourceData objSelection
    .ChartType = xl3DColumn
    .Location xlLocationAsNewSheet
    .Legend.Delete
    .PlotBy = xlColumns
End With

Set objSrcData = Union(objCategories, objSelection)
objChart.SetSourceData objSrcData