Копирование диапазона в другую книгу в цикле

[Drummer_SV]

Не верно работает копирование диапазона. Есть функция, которая в цикле открывает в папке все .xls файлы, выделяет на нужном листе диапазон, потом в текущей книге (где запущена функц.) создает лист и вставляет туда данные. Но в итоге получается что данные вставляются листа текущей книги. Прошу помощи.

пример кода:

While Filename <> ""    ' перебираем все файлы в текущей папке

   If Not Filename Like ThisWorkbook.Name & "*" Then coll.Add Filename

' открываем все файлы из папки
   a = ipath & Filename
   Set ExcelApp = CreateObject("Excel.Application")
    With ExcelApp
        .Visible = True
        .Workbooks.Open a
        .ActiveWorkbook.Sheets("Основное меню").Select
    End With
    'копируем
    
    Range("A1:AW70").Select
    Selection.Copy

' в текущей книге создаем лист

   Set sh = ThisWorkbook.Sheets.Add
   sh.Name = nmList & i
   path2 = ipath & "[" & Filename & "]"

    ThisWorkbook.Sheets(nmList & i).Cells(1, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    
    
i = i + 1
Filename = Dir

Wend

[EducatedFool]

В коде много лишнего...

Попробуйте как-то так (не проверял, ибо это лишь часть макроса)

    Dim wb As Workbook, sh1 As Worksheet ' добавьте эту строку
    Application.ScreenUpdating = False ' отключаем перерисовку экрана

    While Filename <> ""    ' перебираем все файлы в текущей папке

        ' зачем добавляете имя в коллекцию???
        If Not Filename Like ThisWorkbook.Name & "*" Then coll.Add Filename

        a = ipath & Filename

        ' зачем запускать новый экземпляр Excel ???
        ' Set ExcelApp = CreateObject("Excel.Application") ' нафиг не нужно
        Set wb = Workbooks.Open(a)
        Set sh1 = wb.Sheets("Основное меню")


        Set sh = ThisWorkbook.Sheets.Add    ' в текущей книге создаем лист
        sh.Name = nmList & i

        'копируем (точнее, переносим только значения)
        sh.Range("A1:AW70").Value = sh1.Range("A1:AW70").Value
        
        wb.Close False ' закрываем файл без сохранения изменений

        i = i + 1
        Filename = Dir
    Wend

[Drummer_SV]

БОльшое человеческое спасибо! Это то что мне нужно.