Есть 90+ файлов, каждый содержит Н-ное количество листов. Нужные листы находятся на первом месте в файле-книге и имеют одинаковое название. Есть макрос по разбитию всех файлов-книг на отдельные файлы-листы. И макрос по сбору нужных файлов-листов в одну файл-книгу Минусы данного варианта: 1) нужно открыть каждый файл, вставить и запустить в нем макрос. 2) если сразу объединить все файлы в один - нагрузка на комп слишком велика - он долго и громко пыхтит, а потом может еще и зависнуть.
Вопрос: можно ли сделать так, чтобы макрос не перебирал все листы всех файлов, а сразу выбирал только нужные и собирал их в один файл? то есть исходные данные: файлы: A, B, C, D, E, F ... каждый из них содержит листы 1, 2, 3, 4... задача переместить/скопировать все листы "1" в файл "куда скопировать" с наименованием: A_1, B_1, C_1, D_1 и т.д.
исходные макросы: приложены файлы для примера: A, B, C, D
Sub makros()
Dim FilesToOpen
Dim x As Integer
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="All files (*.*), *.*", _
MultiSelect:=True, Title:="Files to Merge")
x = 1
While x <= UBound(FilesToOpen)
Sheets("1").Select
Sheets("1").Copy Before:=Workbooks("куда_скопировать.xlsx").Sheets(1)
x = x + 1
Wend
End Sub
Sub MergeExcelFiles()
Dim fnameList, fnameCurFile As Variant
Dim countFiles, countSheets As Integer
Dim wksCurSheet As Worksheet
Dim wbkCurBook, wbkSrcBook As Workbook
fnameList = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel files to merge", MultiSelect:=True)
If (vbBoolean <> VarType(fnameList)) Then
If (UBound(fnameList) > 0) Then
countFiles = 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set wbkCurBook = ActiveWorkbook
For Each fnameCurFile In fnameList
countFiles = countFiles + 1
Set wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For Sheets("1") In wbkSrcBook.Sheets
Sheets("1").Copy after = Workbooks("куда_скопировать.xlsx").Sheets(1)
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Processed " & countFiles & " files" & vbCrLf & "Merged " & countSheets & " worksheets", Title:="Merge Excel files"
End If
Else
MsgBox "No files selected", Title:="Merge Excel files"
End If
End Sub
Вопросы: 1. Копировать в отдельный файл все листы с наименованиями: 1.1. A_1, 1.2. B_1, 1.3. C_1, 1.4. D_1. 2. Вы, надеюсь, понимаете, что в новом файле повтор имен Листов - недопустим! 2.1. Полагаю, Вы не будете составлять длиннющий список - как "обзывать": совпавшие по именам - листы?! 2.2. Замучаетесь при составлении списка! 2.3. Тем паче, надо указать, непременно, из какого Исходника "приплыл" Лист! 2.4. Предлагаю - к названию Листа - "приклепать" короткое название Исходника: символов 10, думаю, вполне Хватит. 2.5. Полагаю, "отстёгивать" эти символы надо с начала имени Исходника! 3. Думаю, 4-5 файлов-Исходников: вполне достаточно! 3.1. Прикрепляйте Ваши файлы-Исходники!
Вы, надеюсь, понимаете, что в новом файле повтор имен Листов - недопустим! Предлагаю - к названию Листа - "приклепать" короткое название Исходника: символов 10, думаю, вполне Хватит. 2.5. Полагаю, "отстёгивать" эти символы надо с начала имени Исходника
макрос при разделении листов книги на отдельные файлы примерно вашим способом их и сохранял: ActiveWorkbook.SaveAs wb.Path & "\" & s.Name & ".xlsx"
Цитата
3.1. Прикрепляйте Ваши файлы-Исходники!
файлы A,B,C и D - их упрощенный вариант - если макрос сработает на них, то аналогично сработает и на более громоздких исходниках. Но, если вам удобнее с громоздкими - завтра на работе скину их
ussuritiger написал: файлы A,B,C и D - их упрощенный вариант - если макрос сработает на них, то аналогично сработает и на более громоздких исходниках.
Уважаемый ussuritiger! Разумеется: Краткость - сестра таланта!!! Можно, конечно, работать с пустыми листами в Ваших файлах - A,B,C и D! Но мой Макрос, непременно, "споткнется" на Реальных файлах... Я Ваши макросы, вовсе - не собираюсь подвергать "отладке"!!!
ussuritiger написал: вместо "1" будут "Табл.5_Груп.Гор.-Сел.поселения"
Полагаю, в названии этих Листов могут присутствовать ненужные Пробелы: если названия Листов были набраны "врукопашную"! Достаточно ли, "отстегивать" в названии Листа: Табл.5?
да, конечно. Можно добавлять из в начале/в конце название файла или первые 2 символа от названия файла или вообще заменять название листа на название файла. Любой из этих вариантов хорош.
Sub MergeExcelFiles()
Dim fnameList,
fnameCurFile As Variant
Dim countFiles,
countSheets As Integer
Dim wksCurSheet As
Worksheet
Dim wbkCurBook,
wbkSrcBook As Workbook
fnameList =
Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks
(*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", Title:="Choose Excel
files to merge", MultiSelect:=True)
If (vbBoolean
<> VarType(fnameList)) Then
If (UBound(fnameList)
> 0) Then
countFiles
= 0
countSheets = 0
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set
wbkCurBook = ActiveWorkbook
For Each
fnameCurFile In fnameList
countFiles = countFiles + 1
Set
wbkSrcBook = Workbooks.Open(Filename:=fnameCurFile)
For
Each wksCurSheet In wbkSrcBook.Sheets
If
(wksCurSheet.Name = "1") Then
countSheets = countSheets + 1
Cells(i, 1).Value = 2
wksCurSheet.Name = Split(wbkSrcBook.Name, ".", 2)(0) +
"." + wksCurSheet.Name
wksCurSheet.Copy after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)
End If
Next
wbkSrcBook.Close SaveChanges:=False
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox
"Processed " & countFiles & " files" & vbCrLf
& "Merged " & countSheets & " worksheets",
Title:="Merge Excel files"
End If
Else
MsgBox
"No files selected", Title:="Merge Excel files"
End If
End Sub
Вить, ну это уже обсуждалось - для себя любимого можно и через 10 строк писать Вдруг человеку именно так удобно? Мне нет, но я и не пытался даже вникнуть в такой код Одно бросается в глаза сразу - неверное объявление переменных в надежде, что всем им через запятую будет присвоен тип, указанный для последней.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...