Страницы: 1
RSS
Создание документов Excel в папке с именами из ячеек VBA
 
Приветствую, друзья! Прошу помощи:
Как создать в папке документы Excel с названием взятым из ячеек столбца A?
В итоге должно получится 5 файлов с названиями городов
Заранее благодарен
Нужно бежать со всех ног, чтобы только оставаться на месте, а чтобы куда-то попасть, надо бежать как минимум вдвое быстрее!
 
Dyroff, https://www.extendoffice.com/ru/documents/excel/800-create-folders-based-on-excel.html
Не бойтесь совершенства. Вам его не достичь.
 
Mershik, Спасибо, но это про папки
Нужно бежать со всех ног, чтобы только оставаться на месте, а чтобы куда-то попасть, надо бежать как минимум вдвое быстрее!
 
Dyroff, сам я очень плохо разбираюсь в макросах, но этот макрос работает
Код
Sub xls_v_papky()
For i = 2 To 6
      On Error Resume Next
 Filename$ = "C:\Documents\" & Sheets("Города").Cells(i, 1).Value
    Err.Clear: ActiveSheet.Copy: DoEvents
    If Err Then Exit Sub
    ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook
  ' ActiveWorkbook.SaveAs Filename, xlWorkbookNormal
  ' ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close False
Next
End Sub
Изменено: artyrH - 11.07.2019 19:52:49
 
artyrH, Спасибо большое за помощь! Работает.
Только есть один момент, в каждом вновь созданном документе в столбце А копируется список из первого документа. Я конечно дописал строку, чтоб его очищать, но может кто-то из форумчан поможет изначально  избежать его создания.

А пока с этим костылем немного  еще докрутил ваш код, отключил обновления экрана и добавил автоматическое определение заполненного диапазона

Код
Sub xls_v_papky()
Dim LastStr As Double
LastStr = Cells(1, 1).CurrentRegion.Rows.Count ' определяем номер последней заполненной строки
For i = 2 To LastStr
Application.ScreenUpdating = False
On Error Resume Next
 Filename$ = "C:\Users\Desktop\офис\" & Sheets("Города").Cells(i, 1).Value
    Err.Clear: ActiveSheet.Copy: DoEvents
     Range("A:A").ClearContents 'очищаем первый столбец в созданной книге
    If Err Then Exit Sub
    ActiveWorkbook.SaveAs Filename, xlWorkbookDefault ' формат xlsx
'   ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbookMacroEnabled ' формат xlsm  с поддержкой макросов
    ActiveWorkbook.Close False
Next
Application.ScreenUpdating = True
End Sub
Нужно бежать со всех ног, чтобы только оставаться на месте, а чтобы куда-то попасть, надо бежать как минимум вдвое быстрее!
 
Цитата
Dyroff написал:
в каждом вновь созданном документе в столбце А копируется список из первого документа
макрос копирует активный лист. можно это учитывать
Код
Err.Clear: Sheets("Лист1").Copy: DoEvents
 
Может так?
Код
Sub createWorkBook()
    Dim arr(), ikey, book As Workbook
    arr =Range("a2:a6").Value
    For Each ikey In arr
        Set book = Workbooks.Add(1)
        book.SaveAs "C:\Documents" & Application.PathSeparator & ikey & ".xlsx"
        book.Close True
    Next ikey
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, так правильнее. как создать книги с именами из ячеек и сохранить все листы, кроме листа Города ?
 
artyrH, Честно говоря не понял вопрос.
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, результат нужен такой же, как и от макроса из #4, только в создаваемые файлы копируется не активный лист, а все листы, кроме листа Города.
 
эта строка копирует несколько листов. чем заменить эту часть - Array("Лист1", "Лист2", "Лист3") - на все имена листов, кроме имени листа Города?
Код
Err.Clear: Sheets(Array("Лист1", "Лист2", "Лист3")).Copy: DoEvents
 
Nordheim,  Да! То, что надо, спасибо!
 Вот про это
Код
Application.PathSeparator

даже и не знал, что существует)

artyrH,  и Вам спасибо за помощь!

Итоговый вариант, который записал к себе
Код
Sub createWorkBook()
    Dim arr(), ikey, book As Workbook
    Dim LastStr As Double
    
    LastStr = Cells(1, 1).CurrentRegion.Rows.Count ' определяем номер последней заполненной строки
    Application.ScreenUpdating = False
    arr = Range("a2:A" & LastStr).Value
    For Each ikey In arr
        Set book = Workbooks.Add(1)
        book.SaveAs "C:\Users\Desktop\Новая папка" & Application.PathSeparator & ikey & ".xlsx"
        book.Close True
    Next ikey
    Application.ScreenUpdating = True
End Sub
Нужно бежать со всех ног, чтобы только оставаться на месте, а чтобы куда-то попасть, надо бежать как минимум вдвое быстрее!
 
artyrH, Пример переноса всех листов кроме первого в новую книгу и сохранение этой книги.
Если применять к данной теме то код нужно вставить в цикл вместо  необходимо обернуть в цикл по массиву.
Код
Sub moveSheetsNewBook()
    Dim sht As Worksheet, i&
    ReDim arr(1 To ThisWorkbook.Worksheets.Count - 1)
    For Each sht In ThisWorkbook.Worksheets
        If sht.Index <> 1 Then
            i = i + 1
            arr(i) = sht.Name
        End If
    Next
    Sheets(arr).Copy
    With ActiveWorkbook
        .SaveAs ThisWorkbook.Path & Application.PathSeparator & "test.xlsx"
        .Close True
    End With
End Sub
"Все гениальное просто, а все простое гениально!!!"
 
Nordheim, спасибо. работает отлично
Страницы: 1
Наверх