Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Разбить строки одного листа на отдельные книги Эксель - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разбить строки одного листа на отдельные книги Эксель (Макросы/Sub)
Разбить строки одного листа на отдельные книги Эксель
t3308095 Дата: Пятница, 24.06.2022, 11:58 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Всем привет!
Народ , подскажите пожалуйста как решить такую задачу:

есть таблица на одном листе . В таблице N- строк (они могут повторяться)
Нужно создать и записать в отдельную папку N отдельных книг Эксель , где будет всего 1 лист , в котором будет Шапка Таблицы и 1 уникальная строка из исходной таблицы.
К сообщению приложен файл: 7664391.png(116.0 Kb) · 7210993.xlsx(9.9 Kb)


Сообщение отредактировал t3308095 - Пятница, 24.06.2022, 11:59
 
Ответить
СообщениеВсем привет!
Народ , подскажите пожалуйста как решить такую задачу:

есть таблица на одном листе . В таблице N- строк (они могут повторяться)
Нужно создать и записать в отдельную папку N отдельных книг Эксель , где будет всего 1 лист , в котором будет Шапка Таблицы и 1 уникальная строка из исходной таблицы.

Автор - t3308095
Дата добавления - 24.06.2022 в 11:58
msi2102 Дата: Пятница, 24.06.2022, 18:29 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 246
Репутация: 89 ±
Замечаний: 0% ±

Excel 2007
Так?
[vba]
Код
Sub Копия()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = False
    For n = 1 To ThisWorkbook.Worksheets("Лист1").ListObjects("Таблица1").DataBodyRange.Rows.Count
        ThisWorkbook.Worksheets("Лист1").Copy
        With ActiveWorkbook.ActiveSheet.ListObjects("Таблица1").DataBodyRange
            .Rows(1).Value = .Rows(n).Value
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End With
        nm = ActiveSheet.ListObjects("Таблица1").DataBodyRange(1, 1)
        ActiveWorkbook.SaveAs Filename:="C:\Рабочая\111111111\" & nm & ".xlsx"
'       Если не нужно закрывать файл после сохранения, закомментируйте нижнюю строку
        ActiveWorkbook.Close SaveChanges:=False
    Next
Application.CopyObjectsWithCells = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]
Создайте папку "C:\Рабочая\111111111\" или исправьте на нужную в коде
Если такие файлы уже будут присутствовать в этой папке, то они будут заменены
К сообщению приложен файл: 7210993.xlsm(20.6 Kb)


Сообщение отредактировал msi2102 - Пятница, 24.06.2022, 19:53
 
Ответить
СообщениеТак?
[vba]
Код
Sub Копия()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = False
    For n = 1 To ThisWorkbook.Worksheets("Лист1").ListObjects("Таблица1").DataBodyRange.Rows.Count
        ThisWorkbook.Worksheets("Лист1").Copy
        With ActiveWorkbook.ActiveSheet.ListObjects("Таблица1").DataBodyRange
            .Rows(1).Value = .Rows(n).Value
            .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Rows.Delete
        End With
        nm = ActiveSheet.ListObjects("Таблица1").DataBodyRange(1, 1)
        ActiveWorkbook.SaveAs Filename:="C:\Рабочая\111111111\" & nm & ".xlsx"
'       Если не нужно закрывать файл после сохранения, закомментируйте нижнюю строку
        ActiveWorkbook.Close SaveChanges:=False
    Next
Application.CopyObjectsWithCells = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]
Создайте папку "C:\Рабочая\111111111\" или исправьте на нужную в коде
Если такие файлы уже будут присутствовать в этой папке, то они будут заменены

Автор - msi2102
Дата добавления - 24.06.2022 в 18:29
t3308095 Дата: Пятница, 24.06.2022, 20:06 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Так?


Да, так, спасибо:)


Сообщение отредактировал t3308095 - Пятница, 24.06.2022, 21:38
 
Ответить
Сообщение
Так?


Да, так, спасибо:)

Автор - t3308095
Дата добавления - 24.06.2022 в 20:06
t3308095 Дата: Суббота, 25.06.2022, 11:28 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

msi2102,
помогите пожалуйста еще с такой задачей:
Скопировать выделенный диапазон в новые книги Эксель столько раз сколько строк в этом диапазоне...

Как копировать весь лист в новую книгу эксель я благодаря вам научился :) , а как скопировать именно выделенный диапазон ?
Спасибо:)

К сообщению приложен файл: 5605631.xlsm(23.6 Kb)


Сообщение отредактировал t3308095 - Суббота, 25.06.2022, 11:33
 
Ответить
Сообщениеmsi2102,
помогите пожалуйста еще с такой задачей:
Скопировать выделенный диапазон в новые книги Эксель столько раз сколько строк в этом диапазоне...

Как копировать весь лист в новую книгу эксель я благодаря вам научился :) , а как скопировать именно выделенный диапазон ?
Спасибо:)


Автор - t3308095
Дата добавления - 25.06.2022 в 11:28
RAN Дата: Суббота, 25.06.2022, 12:23 | Сообщение № 5
Группа: Друзья
Ранг: Экселист
Сообщений: 5640
Репутация: 1145 ±
Замечаний: 0% ±

2010
Создаете новую книгу.
Копируете в нее нужный диапазон.


Быть или не быть, вот в чем загвоздка!
 
Ответить
СообщениеСоздаете новую книгу.
Копируете в нее нужный диапазон.

Автор - RAN
Дата добавления - 25.06.2022 в 12:23
t3308095 Дата: Суббота, 25.06.2022, 14:26 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Создаете новую книгу.


Спасибо , так и сделал.


Сообщение отредактировал t3308095 - Суббота, 25.06.2022, 14:50
 
Ответить
Сообщение
Создаете новую книгу.


Спасибо , так и сделал.

Автор - t3308095
Дата добавления - 25.06.2022 в 14:26
msi2102 Дата: Воскресенье, 26.06.2022, 17:50 | Сообщение № 7
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 246
Репутация: 89 ±
Замечаний: 0% ±

Excel 2007
Скопировать выделенный диапазон
По тому же принципу:
[vba]
Код
Sub Копия1()
Dim urg As Range, r As Range, n As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = False
With ThisWorkbook.Worksheets("Лист1").ListObjects("Таблица1")
    Set urg = Intersect(Selection, .DataBodyRange)
    If Not urg Is Nothing Then
        k = .HeaderRowRange.Row
        l = .DataBodyRange.Rows.Count
        For Each n In urg.Rows
            ThisWorkbook.Worksheets("Лист1").Copy
            i = 0
            With ActiveWorkbook.ActiveSheet.ListObjects("Таблица1").DataBodyRange
                .Value = .Value
                For Each r In urg.Rows
                    i = i + 1
                    .Rows(i).Value = .Rows(r.Row - k).Value
                Next
                If l > i Then .Offset(i, 0).Resize(.Rows.Count - i, .Columns.Count).Rows.Delete
            End With
            nm = .DataBodyRange(n.Row - k, 1)
            ActiveWorkbook.SaveAs Filename:="C:\Рабочая\111111111\" & nm & ".xlsx"
            ActiveWorkbook.Close SaveChanges:=False
        Next
    End If
End With
Application.CopyObjectsWithCells = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]

Можете выделять как строки целиком так и отдельные ячейки, также будет работать при выделении несмежных диапазонов, например "A3:A4, A6"
PS: единственное проверяйте, чтобы при запуске макроса, ранее созданные файлы с такими именами были закрыты, иначе будет ошибка (нужно писать проверку, сейчас нет время), и избегайте дублей в столбце "A", откуда присваиваются имена файлам, иначе один из них будет переписан
К сообщению приложен файл: 7210993_2.xlsm(22.3 Kb)


Сообщение отредактировал msi2102 - Воскресенье, 26.06.2022, 17:57
 
Ответить
Сообщение
Скопировать выделенный диапазон
По тому же принципу:
[vba]
Код
Sub Копия1()
Dim urg As Range, r As Range, n As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CopyObjectsWithCells = False
With ThisWorkbook.Worksheets("Лист1").ListObjects("Таблица1")
    Set urg = Intersect(Selection, .DataBodyRange)
    If Not urg Is Nothing Then
        k = .HeaderRowRange.Row
        l = .DataBodyRange.Rows.Count
        For Each n In urg.Rows
            ThisWorkbook.Worksheets("Лист1").Copy
            i = 0
            With ActiveWorkbook.ActiveSheet.ListObjects("Таблица1").DataBodyRange
                .Value = .Value
                For Each r In urg.Rows
                    i = i + 1
                    .Rows(i).Value = .Rows(r.Row - k).Value
                Next
                If l > i Then .Offset(i, 0).Resize(.Rows.Count - i, .Columns.Count).Rows.Delete
            End With
            nm = .DataBodyRange(n.Row - k, 1)
            ActiveWorkbook.SaveAs Filename:="C:\Рабочая\111111111\" & nm & ".xlsx"
            ActiveWorkbook.Close SaveChanges:=False
        Next
    End If
End With
Application.CopyObjectsWithCells = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
[/vba]

Можете выделять как строки целиком так и отдельные ячейки, также будет работать при выделении несмежных диапазонов, например "A3:A4, A6"
PS: единственное проверяйте, чтобы при запуске макроса, ранее созданные файлы с такими именами были закрыты, иначе будет ошибка (нужно писать проверку, сейчас нет время), и избегайте дублей в столбце "A", откуда присваиваются имена файлам, иначе один из них будет переписан

Автор - msi2102
Дата добавления - 26.06.2022 в 17:50
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Разбить строки одного листа на отдельные книги Эксель (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!