Всем добрый день! Тема уже заезженная, но я не смог найти решения для себя. прошу помощи специалистов Нашел код (даже вроде на этом сайте выкладывали ссылку) - подскажите пожалуйста, как его изменить, чтобы данные собирались только с первых листов, выбранных книг, вне зависимости от имени этих листов
Код
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Range, rCopy As Range, lCalc As Long, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String
Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Worksheet, bPolyBooks As Boolean, avFiles
Dim wsDataSheet As Worksheet
Dim wbAct As Workbook
Dim bPasteValues As Boolean
On Error Resume Next
'Выбираем диапазон выборки с книг
Set iBeginRange = Range("A3")
'для указания диапазона без диалогового окна:
'Set iBeginRange = Range("A1:A10") 'диапазон указывается нужный
'Если диапазон не выбран - завершаем процедуру
If iBeginRange Is Nothing Then Exit Sub
'Указываем имя листа
'Допустимо указывать в имени листа символы подставки ? и *.
'Если указать только * то данные будут собираться со всех листов
'sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
'Если имя листа не указано - данные будут собраны со вех листов
If sSheetName = "" Then sSheetName = "*"
On Error GoTo 0
'Запрос - вставлять на результирующий лист все данные
'или только значения ячеек (без формул и форматов)
'bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "Excel-VBA") = vbYes)
'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
Выход = MsgBox("Выберите все выгрузки", vbOKCancel)
If Выход = vbCancel Then End
avFiles = Application.GetOpenFilename("All files (*.*), *.*", , "Выбор файлов", , True)
If VarType(avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
lCol = 0
'Else
'avFiles = Array(ThisWorkbook.FullName)
'End If
'отключаем обновление экрана, автопересчет формул и отслеживание событий
'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
'создаем новый лист в книге для сбора
Workbooks.Add.Worksheets(1).Name = "Данные"
Set wsDataSheet = Worksheets("Данные")
'если нужно сделать сбор данных на новый лист книги с кодом
'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'цикл по книгам
For li = LBound(avFiles) To UBound(avFiles)
If bPolyBooks Then
Set wbAct = Workbooks.Open(FileName:=avFiles(li))
Else
Set wbAct = ThisWorkbook
End If
oAwb = wbAct.Name
'цикл по листам
For Each wsSh In wbAct.Worksheets
If wsSh.Name Like sSheetName Then
'Если имя листа совпадает с именем листа, в который собираем данные
'и сбор идет только с активной книги - то переходим к следующему листу
If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange.Count
Case 1 'собираем данные начиная с указанной ячейки и до конца данных
lLastrow = .Cells(Rows.Count, 1).End(xlUp).Row
iLastColumn = .Cells.SpecialCells(xlLastCell).Column
sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
Case Else 'собираем данные с фиксированного диапазона
sCopyAddress = iBeginRange.Address
End Select
lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
'определяем для копирования диапазон только заполненных данных на листе
Set rCopy = Intersect(.Range(sCopyAddress).Parent.UsedRange, .Range(sCopyAddress))
'вставляем имя книги, с которой собраны данные
' If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(rCopy.Rows.Count).Value = oAwb
'если вставляем только значения и форматы ячеек
If bPasteValues Then
rCopy.Copy
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteFormats
Else 'если вставляем все данные ячеек(значения, формулы, форматы и т.д.)
rCopy.Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
End If
End With
End If
NEXT_:
Next wsSh
If bPolyBooks Then wbAct.Close False
Next li
'сохраняем книгу
MsgBox "Все выгрузки собраны" & vbCr & _
"Сохраните куда будет угодно"
Dim FileName As String
Dim Fltr As String
Fltr = "Книга Excel (*.xlsx),*.xlsx"
FileName = Application.GetSaveAsFilename(, Fltr, , "Введите имя файла", "Сохранить")
With ActiveWorkbook
.SaveAs FileName
.Close
End With
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
End With
End Sub
2.3. Приложите файл(ы) с примером (общим весом не более 300Кб) в реальной структуре и форматах данных того, что есть сейчас и того, что хотелось бы на выходе.
спрошу сюда, хоть тема и заезженная, но я пока учусь, потому и не все получается. Как убрать эти запросы чтобы сразу работало выбор Нет (не только значений) и собирались данные с нескольких книг 9т.е. кнопака ДА) ?
'Запрос - вставлять на результирующий лист все данные 'или только значения ячеек (без формул и форматов) bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "Excel-VBA") = vbYes) 'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги) If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True) If VarType(avFiles) = vbBoolean Then Exit Sub bPolyBooks = True lCol = 1 Else avFiles = Array(ThisWorkbook.FullName) End If
бухарик, Доброго времени суток. Во первых, оформите ваш код тегом, смотрим скриншот как это сделать надо. Во вторых, приложите ваш код весь и укажите где именно ошибка. На какой строке? И маленький файл пример. Далее будем посмотреть как говорится.
Пришлосьь воспользоваться Штирлицем, помогает однако)) - Выкладываю Весь код, чтото решил для себя, а не решена проблема чтобы "вставлять значения и форматы" (вроде и меняю bPasteValues = vbYes но что No что Yes вствляет только значения) - и не знаю как отредактировать чтобы сбор листов сразу начинался с директории к примеру диска D/
Код
Sub Consolidated_Range_of_Books_and_Sheets()
Dim iBeginRange As Object, lCalc As Long, lCol As Long
Dim oAwb As String, sCopyAddress As String, sSheetName As String
Dim lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
Dim wsSh As Object, wsDataSheet As Object, bPolyBooks As Boolean, avFiles
Dim wbAct As Workbook
Dim bPasteValues As Boolean
On Error Resume Next
'Выбираем диапазон выборки с книг
'Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _
"1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _
vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8)
'для указания диапазона без диалогового окна:
'Set iBeginRange = Range("A1:A10") 'диапазон указывается нужный
Set iBeginRange = Range("A1") 'диапазон указывается нужный //06/07/2023
'Если диапазон не выбран - завершаем процедуру
If iBeginRange Is Nothing Then Exit Sub
'Указываем имя листа
'Допустимо указывать в имени листа символы подставки ? и *.
'Если указать только * то данные будут собираться со всех листов
'sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр")
'Если имя листа не указано - данные будут собраны со вех листов
'If sSheetName = "" Then sSheetName = "*"
If sSheetName = "" Then sSheetName = "*"
On Error GoTo 0
'Запрос - вставлять на результирующий лист все данные
'или только значения ячеек (без формул и форматов)
'bPasteValues = (MsgBox("Вставлять только значения?", vbQuestion + vbYesNo, "Excel-VBA") = vbYes) // григорян
bPasteValues = vbYes
'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги)
'If MsgBox("Собрать данные с нескольких книг?", vbInformation + vbYesNo, "Excel-VBA") = vbYes Then // григорян
avFiles = Application.GetOpenFilename("Excel files(*.xls*),*.xls*", , "Выбор файлов", , True)
If VarType(avFiles) = vbBoolean Then Exit Sub
bPolyBooks = True
lCol = 1
'Else
' avFiles = Array(ThisWorkbook.FullName)
'End If
'отключаем обновление экрана, автопересчет формул и отслеживание событий
'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
With Application
lCalc = .Calculation
.ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
End With
'создаем новый лист в книге для сбора
Set wsDataSheet = ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
'если нужно сделать сбор данных на новый лист книги с кодом
'Set wsDataSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
'цикл по книгам
For li = LBound(avFiles) To UBound(avFiles)
If bPolyBooks Then
Set wbAct = Workbooks.Open(Filename:=avFiles(li))
Else
Set wbAct = ThisWorkbook
End If
oAwb = wbAct.Name
'цикл по листам
For Each wsSh In wbAct.Sheets
If wsSh.Name Like sSheetName Then
'Если имя листа совпадает с именем листа, в который собираем данные
'и сбор идет только с активной книги - то переходим к следующему листу
If wsSh.Name = wsDataSheet.Name And bPolyBooks = False Then GoTo NEXT_
With wsSh
Select Case iBeginRange.Count
Case 1 'собираем данные начиная с указанной ячейки и до конца данных
lLastrow = .Cells(1, 1).SpecialCells(xlLastCell).Row
iLastColumn = .Cells.SpecialCells(xlLastCell).Column
sCopyAddress = .Range(.Cells(iBeginRange.Row, iBeginRange.Column), .Cells(lLastrow, iLastColumn)).Address
Case Else 'собираем данные с фиксированного диапазона
sCopyAddress = iBeginRange.Address
End Select
lLastRowMyBook = wsDataSheet.Cells.SpecialCells(xlLastCell).Row + 1
'вставляем имя книги, с которой собраны данные
If lCol Then wsDataSheet.Cells(lLastRowMyBook, 1).Resize(Range(sCopyAddress).Rows.Count).Value = oAwb
If bPasteValues Then 'если вставляем только значения
.Range(sCopyAddress).Copy
wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol).PasteSpecial xlPasteValues
Else
.Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol)
End If
End With
End If
NEXT_:
Next wsSh
If bPolyBooks Then wbAct.Close False
Next li
With Application
.ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
End With
End Sub
а чего ожидали-то? vbYes - это числовая константа, как и vbNo. А bPasteValues - булева переменная. Логику надо иногда тоже подключать. Достаточно одного True:
Код
bPasteValues = True
Цитата
бухарик написал: не знаю как отредактировать чтобы сбор листов сразу начинался с директории к примеру диска D/
в этом коде никак, потому что он собирает данные с конкретных указанных файлов, а не с файлов из указанной папки. А вообще на странице сайта с этим кодом за несколько лет скопилась куча комментариев, среди которых есть ответы почти на все вопросы: Как собрать данные с нескольких листов или книг?
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
МатросНаЗебре написал: я направляю код в часть, вставляющую только значения, а он вставляет только значения
В макросе из сообщения 13 нет вообще строки, чтобы вставлять ФОРМАТЫ хоть в каком-то виде. Есть только вставка значений. Присмотритесь к коду здесь же в теме первым сообщением - там есть все нужные для вставки значений и форматов строки. Я отвечал, что нужно изменить для того, чтобы всегда без запроса вставлялись только значения и форматы. Лучше пройдитесь по теме последовательно и вникнете.
P.S. Сначала не сразу въехал, что не ТС вопрос задал.
Дмитрий(The_Prist) Щербаков, соррян, камень не в Ваш огород был. бухарик неправильно воспользовался Вашим советом, и спрашивает "что не так?" В общем, это бухарику было.