Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Сборка первых листов из разных книг в один файл - один лист
 
Добрый вечер, уважаемые форумчане.
Очень прошу Вашей помощи в макросе сбора данных из различных книг первого листа в один файл и один лист.

Пример Файл_3,Файл_2,Файл_1 и Книга-приемник Отчет.xlsb
Прошу макросом собрать из первых листов  Файл_3,Файл_2,Файл_1 диапазона A2:AB данные и перенести их в Отчет.xlsb - лист База диапазон  A2:AB
Заранее огромное Вам спасибо и всех благ.
 
Всегда ли в книге (Файл_1, Файл_2, Файл_3, Файл_n) будет только один лист ?
 
ocet p. Нет. Есть и 2, и 3 листа.
 
Может быть таким образом ?
Код
Option Explicit

Sub a_soberi_dannyye()
    Const shBD = "Baza"
    Const dpznbgBD = "A1"       ' => nachalo diapazona lista "Baza"
    Const dpznbgistnk = "A1"    ' => nachalo diapazona istochnikov
    ' 'clsmax' => kolichestvo stolbtsov dlya kopirovaniya iz diapazona istochnikov
    Const clsmax = 28           ' => simvolicheskoye "A:AB"
    Const ffltr = "All files (*.*), *.*,Excel files (*.xls**), *.xls**"
    
    Dim fto: fto = Application.GetOpenFilename(ffltr, 2, "Files to Merge", , True)
    If TypeName(fto) = "Boolean" Then
        MsgBox "?! @$&#^*&^%*#%&^#%*&#%&_(*(*#%&#%& ?! .... !!!!!!!!" ' ... :)
        Exit Sub
    End If
    
    Dim thswb$, fle, tbl, exl As Object, thswbsh As Object
    
    With ThisWorkbook
        thswb = .Name
        Set thswbsh = .Sheets(shBD)
    End With
    
    Application.ScreenUpdating = False
    
    For Each fle In fto
        If Right(fle, Len(fle) - InStrRev(fle, "\", -1, 1)) <> thswb Then
            Set exl = GetObject(fle)
            With exl
                'Windows(.Name).Visible = True 'Tol'ko dlya testirovaniya
                With .Worksheets(1).Range(dpznbgistnk).CurrentRegion.Columns
                    tbl = .Offset(1, 0).Resize(.Rows.Count - 1, clsmax).Value
                End With
                'Windows(.Name).Visible = False 'Tol'ko dlya testirovaniya
                .Close False
            End With
            Set exl = Nothing
            With thswbsh.Range(dpznbgBD).CurrentRegion.Columns(1)
                .Offset(.Rows.Count, 0).Resize(UBound(tbl, 1), clsmax).Value = tbl: tbl = Empty
            End With
        End If
    Next
    
    thswbsh.Range(dpznbgBD).CurrentRegion.EntireColumn.AutoFit
    Application.ScreenUpdating = True
End Sub
 
А вот эта статья не поможет?
Сборка таблиц из разных файлов Excel с помощью Power Query

PS
Собрал из Ваших 3-х файлов в лист "База PQ", четко следуя инструкции из статьи. Ничего сложного (или, - если поумничать, - экстраординарного :) )
Изменено: Михаил Лебедев - 5 Фев 2020 06:39:47 (добавил файл-пример и PS )
Всё сложное - не нужно. Всё нужное - просто /М. Т. Калашников/
 
ocet p Огромное Вам спасибо. Просто супер!!!!  
Страницы: 1
Читают тему (гостей: 1)
Наверх