Страницы: 1
RSS
Копировать в отдельный файл все листы "1" с наименованиями: A_1, B_1, C_1, D_1
 
Есть 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
Изменено: ussuritiger - 10.07.2019 17:23:36
 
Переместить и копировать - не одно и то же. Уточните
 
Мне совсем непринципиально. Но если вы всё же просите оставить один - то пусть будет переместить
Изменено: ussuritiger - 10.07.2019 13:19:17
 
Я просил только уточнить. Копировать легче.
 
тогда копировать, разумеется.Уточнил первое сообщение.
Изменено: ussuritiger - 10.07.2019 17:15:55
 
такая попытка не сработала:
Код
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
Изменено: ussuritiger - 10.07.2019 16:58:43
 
Код
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
Изменено: ussuritiger - 10.07.2019 17:59:41
 

заменил данную часть:

Код
For Each wksCurSheet
In wbkSrcBook.Sheets                  
 countSheets = countSheets + 1                    
wksCurSheet.Copy
after:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count)             
   Next

на эту под свои задачи:
Код
For Sheets("1") In wbkSrcBook.Sheets                   
 Sheets("1").Copy after = Workbooks("куда_скопировать.xlsx").Sheets(1)
                Next
  
               
В итоге где-то накосячил. Вобщем на сегодня моё знакомство с VBA окончено, продолжу завтра.
Изменено: ussuritiger - 10.07.2019 18:04:47
 
Вопросы:
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 - их упрощенный вариант - если макрос сработает на них, то аналогично сработает и на более громоздких исходниках. Но, если вам удобнее с громоздкими - завтра на работе скину их
 
Цитата
1. Копировать в отдельный файл все листы с наименованиями:
видимо нечетко выразился: изначально они все называются "1" - нужно добавить к ним название соответствующего листа, как в макросе с разделением
 
Цитата
ussuritiger написал:
файлы A,B,C и D - их упрощенный вариант - если макрос сработает на них, то аналогично сработает и на более громоздких исходниках.
Уважаемый ussuritiger!
Разумеется: Краткость - сестра таланта!!!
Можно, конечно, работать с пустыми листами в Ваших файлах - A,B,C и D!
Но мой Макрос, непременно, "споткнется" на Реальных файлах...  ;)
Я Ваши макросы, вовсе - не собираюсь подвергать "отладке"!!! :D :D :D  
 
реальные файлы:
Изменено: ussuritiger - 11.07.2019 13:20:34
 
тогда, соответственно, нужные  названия листов вместо "1" будут "Табл.5_Груп.Гор.-Сел.поселения"
 
Цитата
ussuritiger написал:
вместо "1" будут "Табл.5_Груп.Гор.-Сел.поселения"
Полагаю, в названии этих Листов могут присутствовать ненужные Пробелы: если названия Листов были набраны "врукопашную"!  :D
Достаточно ли, "отстегивать" в названии Листа: Табл.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 строк писать :) Вдруг человеку именно так удобно? Мне нет, но я и не пытался даже вникнуть в такой код :)
Одно бросается в глаза сразу - неверное объявление переменных в надежде, что всем им через запятую будет присвоен тип, указанный для последней.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Страницы: 1
Наверх