Добрый вечер. В макросе реализован свод из разных книг в одну. Подскажите, пожалуйста, возможно ли сделать так, что бы по названию книги информация копировалась в лист с таким же названием? Как доработать макрос, что бы копировались все строки, а не только первая.
В архиве один файл рабочий, но сводит информацию только на первый лист. Во вторых двух листах показано как должно получиться. В папке "база для свода" находятся файлы откуда надо сводить информацию по названию файлов.
Программа
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, т.к. она нужна для каких-то специфических случаев, когда нужно спереди числа подставлять пробел.
Внесите изменения, которые я описал, и я потом дальше посмотрю вашу программу.
Спасибо. Ничего не знала об этом всем.
Программа
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".
Добрый день. Как-то так?
Программа
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
Спасибо.
Почему-то ругается на
Set KATALOG = FS.GetFolder(strFN_folder)
У меня нет ошибки. Значит нет папки "Общая база" в папке, в которой находится файл-макрос:
strFN_folder = Application.ActiveWorkbook.Path + "\Общая база"
Я не внимательная совсем. Не заметила, что Вы поменяли в коде название общей папки.
Спасибо большое, особенно за комментарии и за важные замечания.
А еще можно спросить, как сделать так, что бы столбец "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
Спасибо большущее.
Все работает как надо.
Очень благодарна за помощь.