Всем привет! Народ , подскажите пожалуйста как решить такую задачу:
есть таблица на одном листе . В таблице N- строк (они могут повторяться) Нужно создать и записать в отдельную папку N отдельных книг Эксель , где будет всего 1 лист , в котором будет Шапка Таблицы и 1 уникальная строка из исходной таблицы.
Всем привет! Народ , подскажите пожалуйста как решить такую задачу:
есть таблица на одном листе . В таблице N- строк (они могут повторяться) Нужно создать и записать в отдельную папку N отдельных книг Эксель , где будет всего 1 лист , в котором будет Шапка Таблицы и 1 уникальная строка из исходной таблицы.t3308095
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\" или исправьте на нужную в коде Если такие файлы уже будут присутствовать в этой папке, то они будут заменены
Так? [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
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", откуда присваиваются имена файлам, иначе один из них будет переписан
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
Добрый день! Подскажите, пожалуйста Почему при разделении, цвет ячеек не переносится так как было, а фиксируется в одном и том же диапазоне в каждой строке.
Добрый день! Подскажите, пожалуйста Почему при разделении, цвет ячеек не переносится так как было, а фиксируется в одном и том же диапазоне в каждой строке.Молох
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
, а как скопировать именно выделенный диапазон ?
