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

[Rus23]

Добрый вечер. В макросе реализован свод из разных книг в одну. Подскажите, пожалуйста, возможно ли сделать так, что бы по названию книги информация копировалась в лист с таким же названием? Как доработать макрос, что бы копировались все строки, а не только первая.
В архиве один файл рабочий, но сводит информацию только на первый лист. Во вторых двух листах показано как должно получиться. В папке "база для свода" находятся файлы откуда надо сводить информацию по названию файлов.

Программа

Sub LLL()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim Im_Main, Put_File, Put_File_SVOD, NAME_SVOD, schet, str_pch As Variant

Im_Main = ActiveWorkbook.Name
Put_File = Application.ActiveWorkbook.Path + "\БАЗА ДЛЯ СВОДА\"
Put_File_SVOD = Application.ActiveWorkbook.Path + "\"


Dim FS, KATALOG, FILE, MASSIV As Object
Set FS = CreateObject("Scripting.FileSystemObject")
    Set KATALOG = FS.GetFolder(Put_File)
    Set MASSIV = KATALOG.Files
   
    schet = 0
    For Each FILE In MASSIV
        schet = schet + 1
    Next

Sheets("Свод").Select
    Rows("2:65000").Select
    Selection.Delete Shift:=xlUp
   
NAME_SVOD = Trim(Range("G1").Value)
   
str_pch = 2
If schet <> 0 Then
   For Each FILE In MASSIV
       Workbooks.Open Filename:=Trim(FILE)
             
       Rows("2:2").Select
       Selection.Copy
       
       Windows(Im_Main).Activate
       Rows(Trim(Str(str_pch)) + ":" + Trim(Str(str_pch))).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    Windows(Dir(Trim(FILE))).Activate
    ActiveWindow.Close

    str_pch = str_pch + 1
   Next
End If

    Sheets("Свод").Copy
   
    ActiveWorkbook.SaveAs Filename:= _
        Put_File_SVOD + NAME_SVOD + ".XLS", FileFormat _
        :=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
        False, CreateBackup:=False
    ActiveWindow.Close


MsgBox "ГОТОВО"

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[свернуть]

[вложение удалено администратором]

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

Цитата:
Dim Im_Main, Put_File, Put_File_SVOD, NAME_SVOD, schet, str_pch As Variant

Если вы этим кодом присваиваете всем переменным тип данных 'Variant", то это неправильно.
В VBA надо указывать тип данных для каждой переменной:
Dim Im_Main As Variant, Put_File As Variant, Put_File_SVOD As Variant
Dim NAME_SVOD As Variant, schet As Variant, str_pch As Variant

В случае с типом Variant это неудобно смотреть. Но если вы сделаете тип данных Long (или любой другой), то увидите, что у всех переменных кроме последней будет тип Variant:
Dim Im_Main, Put_File, Put_File_SVOD, NAME_SVOD, schet, str_pch As Long

Тип данных Variant можно вообще не указывать, чтобы уменьшить кол-во кода:
Dim Im_Main, Put_File, Put_File_SVOD, NAME_SVOD, schet, str_pch

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

Сделайте это: https://forumvba.ru/index.php?topic=402.0
Вверху модуля всегда должно быть "Option Explicit".

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

Давайте программные имена листам - не нужно работать так, как будто нужный лист активный (отображается на мониторе):
Dim shSvod As Worksheet
Set shSvod = Sheets("Свод")
shSvod.Rows("2:65000").Delete Shift:=xlUp

PS. Программные имена иначе называются "ссылками".

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

Для перевода данных в тип данных String не используйте функцию Str, а используйте функцию CStr:
Trim(Str(str_pch)
CStr(str_pch)

В этом случае не нужно использовать Trim. Вообще, забудьте пока, что есть функция Str, т.к. она нужна для каких-то специфических случаев, когда нужно спереди числа подставлять пробел.

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

Внесите изменения, которые я описал, и я потом дальше посмотрю вашу программу.

[Rus23]

Спасибо. Ничего не знала об этом всем.

Программа

Option Explicit

Sub LLL()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim Im_Main, Put_File, Put_File_SVOD, NAME_SVOD, schet, str_pch
Dim shSvod As Worksheet

Im_Main = ActiveWorkbook.Name
Put_File = Application.ActiveWorkbook.Path + "\БАЗА ДЛЯ СВОДА\"
Put_File_SVOD = Application.ActiveWorkbook.Path + "\"


Dim FS, KATALOG, FILE, MASSIV As Object
Set FS = CreateObject("Scripting.FileSystemObject")
    Set KATALOG = FS.GetFolder(Put_File)
    Set MASSIV = KATALOG.Files
   
    schet = 0
    For Each FILE In MASSIV
        schet = schet + 1
    Next

Set shSvod = Sheets("Свод")
shSvod.Rows("2:65000").Delete Shift:=xlUp

   
NAME_SVOD = Range("G1").Value
   
str_pch = 2
If schet <> 0 Then
   For Each FILE In MASSIV
       Workbooks.Open Filename:=FILE
             
       Rows("2:2").Select
       Selection.Copy
       
       Windows(Im_Main).Activate
       Rows((CStr(str_pch)) + ":" + (CStr(str_pch))).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    Windows(Dir(FILE)).Activate
    ActiveWindow.Close

    str_pch = str_pch + 1
   Next
End If

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[свернуть]

[вложение удалено администратором]

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

Если решили присвоить листу программное имя (shSvod), то его надо использовать во всём коде. Например здесь:
NAME_SVOD = Range("G1").Value

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

Здесь так же переменные неправильно созданы:
Dim FS, KATALOG, FILE, MASSIV As Object

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

Создайте ещё программное имя для листа с именем "Im_Main".

[Rus23]

Добрый день. Как-то так?

Программа

Option Explicit
Sub LLL()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim Im_Main, Put_File, Put_File_SVOD, NAME_SVOD, schet, str_pch
Dim shSvod As Worksheet, shSv As Worksheet

Im_Main = ActiveWorkbook.Name
Put_File = Application.ActiveWorkbook.Path + "\Общая база\"
Put_File_SVOD = Application.ActiveWorkbook.Path + "\"


Dim FS As Object, KATALOG As Object, FILE As Object, MASSIV As Object
Set FS = CreateObject("Scripting.FileSystemObject")
    Set KATALOG = FS.GetFolder(Put_File)
    Set MASSIV = KATALOG.Files
   
    schet = 0
    For Each FILE In MASSIV
        schet = schet + 1
    Next

Set shSvod = Sheets("Свод")
shSvod.Rows("2:65000").Delete Shift:=xlUp

       
str_pch = 2
If schet <> 0 Then
   For Each FILE In MASSIV
       Workbooks.Open Filename:=FILE
             
       shSv.Rows("2:2").Copy
       
       Windows(Im_Main).Activate
        shSv.Rows((CStr(str_pch)) + ":" + (CStr(str_pch))).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

    Windows(Dir(FILE)).Activate
    ActiveWindow.Close

    str_pch = str_pch + 1
   Next
End If

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

[свернуть]

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

Это не решение, просто я пока читал код, увидел лишнее.
Я убрал переменную "schet".

Программа

Sub LLL()

    Dim Im_Main, Put_File, Put_File_SVOD, NAME_SVOD, str_pch
    Dim shSvod As Worksheet, shSv As Worksheet
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   
    Im_Main = ActiveWorkbook.Name
    Put_File = Application.ActiveWorkbook.Path + "\Общая база\"
    Put_File_SVOD = Application.ActiveWorkbook.Path + "\"
   
    Dim FS As Object, KATALOG As Object, FILE As Object, MASSIV As Object
    Set FS = CreateObject("Scripting.FileSystemObject")
    Set KATALOG = FS.GetFolder(Put_File)
    Set MASSIV = KATALOG.Files
       
    Set shSvod = Sheets("Свод")
    shSvod.Rows("2:65000").Delete Shift:=xlUp
           
    str_pch = 2
    If MASSIV.Count <> 0 Then
       For Each FILE In MASSIV
           Workbooks.Open FileName:=FILE
                 
           shSv.Rows("2:2").Copy
           
           Windows(Im_Main).Activate
            shSv.Rows((CStr(str_pch)) + ":" + (CStr(str_pch))).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
        Application.CutCopyMode = False
   
        Windows(Dir(FILE)).Activate
        ActiveWindow.Close
   
        str_pch = str_pch + 1
       Next
    End If
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

[свернуть]

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

Программа

Sub LLL()

    Dim strFN_folder
    Dim bkSvod As Workbook, shSvod1 As Worksheet, shSvod2 As Worksheet, shSrc As Worksheet
    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
        ' Копирование.
        shSrc.Rows(2 & ":" & lr).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
        ' Копирование на сводный лист.
        shSvod2.Rows(lr).PasteSpecial Paste:=xlPasteValues
       
        ' Закрытие файла-источника.
        shSrc.Parent.Close SaveChanges:=False
   
    Next
   
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

[свернуть]

[Rus23]

Спасибо.
Почему-то ругается на
Set KATALOG = FS.GetFolder(strFN_folder)

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

У меня нет ошибки. Значит нет папки "Общая база" в  папке, в которой находится файл-макрос:
strFN_folder = Application.ActiveWorkbook.Path + "\Общая база"