Excel Макрос: Свод данных из разных книг в одну

[Rus23]

Я не внимательная совсем. Не заметила, что Вы поменяли в коде название общей папки.
Спасибо большое, особенно за комментарии и за важные замечания.
А еще можно спросить, как сделать так, что бы столбец "D" копировался в столбец "G"?

[Администратор]

Я забыл, что поменял имя папки. Просто в вашем коде имя папки не совпало с папкой, которую выложили на форуме.

[Администратор]

Программа

Sub LLL()

    Dim bkSvod As Workbook, shSvod1 As Worksheet, shSvod2 As Worksheet, shSrc As Worksheet
    Dim rng As Range
    Dim strFN_folder As String
    Dim var, lr As Long
   
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    ' FN означает FullName (полное имя). То есть полное имя папки.
        ' На конце слеша нет, т.к. он в данный момент не нужен. А если нужен,
        ' то удобнее подставлять в его в том месте, где используется.
    strFN_folder = Application.ActiveWorkbook.Path + "\Общая база"
   
    Dim FS As Object, KATALOG As Object, FILE As Object
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set KATALOG = FS.GetFolder(strFN_folder)
    If KATALOG.FILES.Count = 0 Then
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
    End If
   
    ' Присвоение программного имени "bkSvod" активному файлу.
        ' Далее макрос будет открывать файлы и активный файл будет меняться.
    Set bkSvod = ActiveWorkbook
       
    Set shSvod1 = Sheets("Свод")
    shSvod1.Rows("2:65000").Delete Shift:=xlUp
           
    For Each FILE In KATALOG.FILES
       
        ' Присвоение программного имени нужному сводному листу.
        ' Запись имени файла (без пути) в переменную, чтобы затем в переменной обработать данные.
        var = FILE.Name
        ' Удаление расширения из имени файла.
        var = Left(var, InStrRev(var, ".") - 1)
        ' Присвоение имени.
        Set shSvod2 = bkSvod.Worksheets(var)
       
        ' Удаление старых данных на сводном листе.
        shSvod2.Rows("2:65000").Delete Shift:=xlUp
       
        ' Открытие файла-источника и присвоение программного имени "shSrc" первому листу.
        Set shSrc = Workbooks.Open(Filename:=FILE).Worksheets(1)
       
        ' Копирование данных из листа-источника на сводные листы.
        ' Поиск последней строки на листе-источнике по столбцу "A".
            ' При использовании метода "End" на листе-источнике не должно быть скрытых строк.
        lr = shSrc.Cells(shSrc.Rows.Count, "A").End(xlUp).Row
        ' Присваивание имени "rng" строкам, которые надо скопировать.
        Set rng = shSrc.Rows(2 & ":" & lr)
        ' Копирование.
        rng.Copy
        ' Поиск последней строки на общем сводном листе и добавляется 1.
        lr = shSvod1.Cells(shSvod1.Rows.Count, "A").End(xlUp).Row + 1
        ' Копирование на общий сводный лист.
        shSvod1.Rows(lr).PasteSpecial Paste:=xlPasteValues
        ' Поиск последней строки на сводном листе и добавляется 1.
        lr = shSvod2.Cells(shSvod2.Rows.Count, "A").End(xlUp).Row + 1
        ' Копирование на сводный лист.
        rng.Columns("A:C").Copy
        shSvod2.Cells(lr, "A").PasteSpecial Paste:=xlPasteValues
        rng.Columns("D").Copy
        shSvod2.Cells(lr, "G").PasteSpecial Paste:=xlPasteValues
       
        ' Закрытие файла-источника.
        shSrc.Parent.Close SaveChanges:=False
   
    Next
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

[свернуть]

[Rus23]

Спасибо большущее.
Все работает как надо.
Очень благодарна за помощь.