Добрый день! Помогите объеденить два макроса, первый макрос объединяет все все книги в одну, на разных листал. Второй макрос объединяет все листы в один список. Как сделать это всё одним макросом?
Добрый день! Помогите объеденить два макроса, первый макрос объединяет все все книги в одну, на разных листал. Второй макрос объединяет все листы в один список. Как сделать это всё одним макросом?elita86
Первый макрос, объединяющий все книги в одну [vba]
Code
Sub CombineWorkbooks() Dim FilesToOpen Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.csv), *.csv", _ MultiSelect:=True, Title:="Files to Merge") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Не выбрано ни одного файла!" GoTo ExitHandler End If x = 1 While x <= UBound(FilesToOpen) Workbooks.Open Filename:=FilesToOpen(x) Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) x = x + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub
[/vba]
Первый макрос, объединяющий все книги в одну [vba]
Code
Sub CombineWorkbooks() Dim FilesToOpen Dim x As Integer On Error GoTo ErrHandler Application.ScreenUpdating = False FilesToOpen = Application.GetOpenFilename _ (FileFilter:="Microsoft Excel Files (*.csv), *.csv", _ MultiSelect:=True, Title:="Files to Merge") If TypeName(FilesToOpen) = "Boolean" Then MsgBox "Не выбрано ни одного файла!" GoTo ExitHandler End If x = 1 While x <= UBound(FilesToOpen) Workbooks.Open Filename:=FilesToOpen(x) Sheets().Move After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) x = x + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub ErrHandler: MsgBox Err.Description Resume ExitHandler End Sub
Второй макрос, объединяющий все листы в список Sub СобратьДанные() Dim ws As Worksheet Worksheets.Add before:=Sheets(1) For Each ws In Worksheets If Not ws Is ActiveSheet And Not ws.Name Like "прогр*" Then ws.UsedRange.Copy Cells(Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1) End If Next Rows(1).Delete End Sub
Второй макрос, объединяющий все листы в список Sub СобратьДанные() Dim ws As Worksheet Worksheets.Add before:=Sheets(1) For Each ws In Worksheets If Not ws Is ActiveSheet And Not ws.Name Like "прогр*" Then ws.UsedRange.Copy Cells(Cells.SpecialCells(xlCellTypeLastCell).Row + 1, 1) End If Next Rows(1).Delete End Subelita86
Извеняюсь, второй макрос не верный, вот верный Sub СобратьДанные() Dim ws As Worksheet Worksheets.Add before:=Sheets(1) For Each ws In Worksheets If Not ws Is ActiveSheet And Not ws.Name Like "прогр*" Then ws.UsedRange.Offset(1).Copy [a1048576].End(xlUp)(2) End If Next Rows(1).Delete End Sub
Извеняюсь, второй макрос не верный, вот верный Sub СобратьДанные() Dim ws As Worksheet Worksheets.Add before:=Sheets(1) For Each ws In Worksheets If Not ws Is ActiveSheet And Not ws.Name Like "прогр*" Then ws.UsedRange.Offset(1).Copy [a1048576].End(xlUp)(2) End If Next Rows(1).Delete End Subelita86
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
