Доброго времени суток, уважаемые форумчане! Вновь возник вопрос, ответ на который на страницах нашего замечательного форума я не нашел. Имеется файл с данными на 4 листах. Требуется на пятом листе собрать данные с тех четырех листов в первый столбец - первый столбец, во второй - третий, в третий - четвертый. В массивах пустых строк нет, т.е. можно сделать условие до первой пустой ячейки. Может есть какие мысли?) Заранее спасибо! К сожалению файл приложить не смогу, т.к.: 1. Нахожусь на работе, где интернет через удаленное рабочее место без возможности закачивания файлов 2. В файле содержатся конфедициальные сведения (банк). Если без файла не получится, попробую вечером что-то похожее выложить... Прошу прощения за неудобства
В интернете нашел такой интересный код, а ума переделать под себя не хватает. В данном коде имена листов задаются, а мне нужно с нескольких четко перечисленных листов (Лист1, Лист3, Лист4, Лист5), но это не критично. Самое главное - нужно чтобы данные переносились в уже созданный лист (не удаляя строки). Также желательно, чтобы можно было задавать столбцы (тоже не критично).
[vba]
Код
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
On Error Resume Next 'Выбираем диапазон выборки с книг Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _ "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _ vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8) 'Если диапазон не выбран - завершаем процедуру If iBeginRange Is Nothing Then Exit Sub 'Указываем имя листа 'Допустимо указывать в имени листа символы подставки ? и *. 'Если указать только * то данные будут собираться со всех листов sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр") 'Если имя листа не указано - данные будут собраны со вех листов If sSheetName = "" Then sSheetName = "*" On Error GoTo 0 'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги) 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 'создаем новый лист в книге для сбора ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) Set wsDataSheet = ThisWorkbook.ActiveSheet 'цикл по книгам For li = LBound(avFiles) To UBound(avFiles) If bPolyBooks Then Workbooks.Open Filename:=avFiles(li) oAwb = Dir(avFiles(li), vbDirectory) 'цикл по листам For Each wsSh In Workbooks(oAwb).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 .Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol) End With End If NEXT_: Next wsSh If bPolyBooks Then Workbooks(oAwb).Close False Next li With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc End With End Sub
[/vba]
Доброго времени суток, уважаемые форумчане! Вновь возник вопрос, ответ на который на страницах нашего замечательного форума я не нашел. Имеется файл с данными на 4 листах. Требуется на пятом листе собрать данные с тех четырех листов в первый столбец - первый столбец, во второй - третий, в третий - четвертый. В массивах пустых строк нет, т.е. можно сделать условие до первой пустой ячейки. Может есть какие мысли?) Заранее спасибо! К сожалению файл приложить не смогу, т.к.: 1. Нахожусь на работе, где интернет через удаленное рабочее место без возможности закачивания файлов 2. В файле содержатся конфедициальные сведения (банк). Если без файла не получится, попробую вечером что-то похожее выложить... Прошу прощения за неудобства
В интернете нашел такой интересный код, а ума переделать под себя не хватает. В данном коде имена листов задаются, а мне нужно с нескольких четко перечисленных листов (Лист1, Лист3, Лист4, Лист5), но это не критично. Самое главное - нужно чтобы данные переносились в уже созданный лист (не удаляя строки). Также желательно, чтобы можно было задавать столбцы (тоже не критично).
[vba]
Код
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
On Error Resume Next 'Выбираем диапазон выборки с книг Set iBeginRange = Application.InputBox("Выберите диапазон сбора данных." & vbCrLf & _ "1. При выборе только одной ячейки данные будут собраны со всех листов начиная с этой ячейки. " & _ vbCrLf & "2. При выделении нескольких ячеек данные будут собраны только с указанного диапазона всех листов.", Type:=8) 'Если диапазон не выбран - завершаем процедуру If iBeginRange Is Nothing Then Exit Sub 'Указываем имя листа 'Допустимо указывать в имени листа символы подставки ? и *. 'Если указать только * то данные будут собираться со всех листов sSheetName = InputBox("Введите имя листа, с которого собирать данные(если не указан, то данные собираются со всех листов)", "Параметр") 'Если имя листа не указано - данные будут собраны со вех листов If sSheetName = "" Then sSheetName = "*" On Error GoTo 0 'Запрос сбора данных с книг(если Нет - то сбор идет с активной книги) 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 'создаем новый лист в книге для сбора ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count) Set wsDataSheet = ThisWorkbook.ActiveSheet 'цикл по книгам For li = LBound(avFiles) To UBound(avFiles) If bPolyBooks Then Workbooks.Open Filename:=avFiles(li) oAwb = Dir(avFiles(li), vbDirectory) 'цикл по листам For Each wsSh In Workbooks(oAwb).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 .Range(sCopyAddress).Copy wsDataSheet.Cells(lLastRowMyBook, 1).Offset(, lCol) End With End If NEXT_: Next wsSh If bPolyBooks Then Workbooks(oAwb).Close False Next li With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc End With End Sub
К сожалению, нет. Мне нужно чтобы столбец А нескольких листов копировался в столбец А итогового файла и т.д. А у вас он с одного листа копирует в итоговый, а с других листов не копирует(((
К сожалению, нет. Мне нужно чтобы столбец А нескольких листов копировался в столбец А итогового файла и т.д. А у вас он с одного листа копирует в итоговый, а с других листов не копирует(((jurafenix
Sub ertert() Dim v For Each v In Array("Лист1", "Лист2", "Лист3", "Лист4") With Sheets(v) With .Range("A1", .Cells(Rows.Count, 1).End(xlUp)) Union(.Columns(1), .Offset(, 2).Resize(, 2)).Copy Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1) End With End With Next End Sub
[/vba]
jurafenix, может как-то так?: [vba]
Код
Sub ertert() Dim v For Each v In Array("Лист1", "Лист2", "Лист3", "Лист4") With Sheets(v) With .Range("A1", .Cells(Rows.Count, 1).End(xlUp)) Union(.Columns(1), .Offset(, 2).Resize(, 2)).Copy Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1) End With End With Next End Sub
Всё, окончательная структура файла утверждена и пример проработан) Задача следующая: Нужно чтобы с Листа "ОСВрубли7777" и Листа "ОСВрублиБФ" Данные копировались в следующесм порядке: 1 столбец в 1 столбец 3 столбец во 2 4 в 3 5 в 4 6 в 5 и 8 в 6
С листа "Банк2рубли" данные копировались в следующем порядке 1 столбец в 1 столбец 2 столбец в 6 3 столбец в 5 5 столбец (потом будет заполнен) во второй столбец.
Если это реально, то буду очень благодарен реализации данного проекта!
Заранее спасибо, дорогие форумчане!
Всё, окончательная структура файла утверждена и пример проработан) Задача следующая: Нужно чтобы с Листа "ОСВрубли7777" и Листа "ОСВрублиБФ" Данные копировались в следующесм порядке: 1 столбец в 1 столбец 3 столбец во 2 4 в 3 5 в 4 6 в 5 и 8 в 6
С листа "Банк2рубли" данные копировались в следующем порядке 1 столбец в 1 столбец 2 столбец в 6 3 столбец в 5 5 столбец (потом будет заполнен) во второй столбец.
Если это реально, то буду очень благодарен реализации данного проекта!
Sub ertert() Dim lr& With Sheets("ОСВрубли7777").Range("A1").CurrentRegion Union(.Columns(1), .Columns(3).Resize(, 4), .Columns(8)).Copy Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1) End With lr = Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1).Row With Sheets("Банк2рубли").Range("A1").CurrentRegion .Columns(1).Copy Sheets("Лист5").Cells(lr, 1) .Columns(2).Copy Sheets("Лист5").Cells(lr, 6) .Columns(3).Copy Sheets("Лист5").Cells(lr, 5) .Columns(5).Copy Sheets("Лист5").Cells(lr, 2) End With End Sub
[/vba]
пробуйте [vba]
Код
Sub ertert() Dim lr& With Sheets("ОСВрубли7777").Range("A1").CurrentRegion Union(.Columns(1), .Columns(3).Resize(, 4), .Columns(8)).Copy Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1) End With lr = Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1).Row With Sheets("Банк2рубли").Range("A1").CurrentRegion .Columns(1).Copy Sheets("Лист5").Cells(lr, 1) .Columns(2).Copy Sheets("Лист5").Cells(lr, 6) .Columns(3).Copy Sheets("Лист5").Cells(lr, 5) .Columns(5).Copy Sheets("Лист5").Cells(lr, 2) End With End Sub
nilem, c листа ОСВрублиБФ и ОСВрубли7777 данные не копирует :( Только берет с Банк2рубли данные и мешает их с данными из ОСВрубли7777. Видимо данные из Банк2рубли просто накладываются на данные ОСВрубли7777
nilem, c листа ОСВрублиБФ и ОСВрубли7777 данные не копирует :( Только берет с Банк2рубли данные и мешает их с данными из ОСВрубли7777. Видимо данные из Банк2рубли просто накладываются на данные ОСВрубли7777jurafenix
Сообщение отредактировал jurafenix - Суббота, 21.02.2015, 12:25
Ну если макрос что-то там не копирует, значит так и должно быть давайте добавим еще три строчки: [vba]
Код
Sub ertert() Dim lr& With Sheets("ОСВрубли7777").Range("A1").CurrentRegion Union(.Columns(1), .Columns(3).Resize(, 4), .Columns(8)).Copy Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1) End With With Sheets("ОСВрублиБФ").Range("A1").CurrentRegion Union(.Columns(1), .Columns(3).Resize(, 4), .Columns(8)).Copy Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1) End With lr = Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1).Row With Sheets("Банк2рубли").Range("A1").CurrentRegion .Columns(1).Copy Sheets("Лист5").Cells(lr, 1) .Columns(2).Copy Sheets("Лист5").Cells(lr, 6) .Columns(3).Copy Sheets("Лист5").Cells(lr, 5) .Columns(5).Copy Sheets("Лист5").Cells(lr, 2) End With End Sub
[/vba] если так тоже не захочет работать, то нужен пример вашего файла
Ну если макрос что-то там не копирует, значит так и должно быть давайте добавим еще три строчки: [vba]
Код
Sub ertert() Dim lr& With Sheets("ОСВрубли7777").Range("A1").CurrentRegion Union(.Columns(1), .Columns(3).Resize(, 4), .Columns(8)).Copy Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1) End With With Sheets("ОСВрублиБФ").Range("A1").CurrentRegion Union(.Columns(1), .Columns(3).Resize(, 4), .Columns(8)).Copy Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1) End With lr = Sheets("Лист5").Cells(Rows.Count, 1).End(xlUp)(2, 1).Row With Sheets("Банк2рубли").Range("A1").CurrentRegion .Columns(1).Copy Sheets("Лист5").Cells(lr, 1) .Columns(2).Copy Sheets("Лист5").Cells(lr, 6) .Columns(3).Copy Sheets("Лист5").Cells(lr, 5) .Columns(5).Copy Sheets("Лист5").Cells(lr, 2) End With End Sub
[/vba] если так тоже не захочет работать, то нужен пример вашего файлаnilem
Яндекс.Деньги 4100159601573
Сообщение отредактировал nilem - Суббота, 21.02.2015, 12:28