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

Вход

Регистрация

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

 

= Мир MS Excel/Создать из одной книги много по шаблону - Мир MS Excel

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

Добрый день, помогите с макросом пожалуйста.

В книге 3 столбца, в столбце А и B значения. В столбце С - порядковый номер реестра.

Надо создать новую книгу которая будет называться номером реестра и содержать в себе данные из первых 2 столбцов соответствующих этому реестру (и желательно заголовок таблицы).
Заранее спасибо
К сообщению приложен файл: __.xlsx(9.4 Kb)
 
Ответить
СообщениеДобрый день, помогите с макросом пожалуйста.

В книге 3 столбца, в столбце А и B значения. В столбце С - порядковый номер реестра.

Надо создать новую книгу которая будет называться номером реестра и содержать в себе данные из первых 2 столбцов соответствующих этому реестру (и желательно заголовок таблицы).
Заранее спасибо

Автор - Leko
Дата добавления - 03.12.2022 в 22:57
Kuzmich Дата: Воскресенье, 04.12.2022, 11:51 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 706
Репутация: 154 ±
Замечаний: 0% ±

Excel 2003
Цитата
помогите с макросом

[vba]
Код
Sub RaznestiReestr()
Dim i As Long
Dim n As Long
Dim Criterij As String
Dim iName As String
Dim WCur As Worksheet
Dim WbN As Workbook
Dim AutoFilter As AutoFilter
Application.ScreenUpdating = False
   Set WCur = ThisWorkbook.Worksheets("Лист2")
   Columns("E").ClearContents
          'отбор уникальных значений столбца C в столбец E
    Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                    , CopyToRange:=Range("E1"), Unique:=True
          'количество уникальных значений
    n = Cells(Rows.Count, "E").End(xlUp).Row
    For i = 2 To n          'цикл по уникальным значениям
        Criterij = Cells(i, "E")
        iName = "Номер реестра_" & Criterij    'имя новой книги
    'создаем новую книгу с одним листом
      Set WbN = Workbooks.Add(xlWBATWorksheet)
    'ставим автофильтр по столбцу C
          WCur.Range("C1").CurrentRegion.AutoFilter 3, Criterij
    'копируем видимые строки в новую книгу
        WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1")
        WCur.AutoFilter.Range.AutoFilter
         
        WbN.Sheets("Лист1").Columns("A:C").AutoFit
        WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
        WbN.Close SaveChanges:=True
    Next
Application.ScreenUpdating = True
End Sub
[/vba]
 
Ответить
Сообщение
Цитата
помогите с макросом

[vba]
Код
Sub RaznestiReestr()
Dim i As Long
Dim n As Long
Dim Criterij As String
Dim iName As String
Dim WCur As Worksheet
Dim WbN As Workbook
Dim AutoFilter As AutoFilter
Application.ScreenUpdating = False
   Set WCur = ThisWorkbook.Worksheets("Лист2")
   Columns("E").ClearContents
          'отбор уникальных значений столбца C в столбец E
    Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy _
                    , CopyToRange:=Range("E1"), Unique:=True
          'количество уникальных значений
    n = Cells(Rows.Count, "E").End(xlUp).Row
    For i = 2 To n          'цикл по уникальным значениям
        Criterij = Cells(i, "E")
        iName = "Номер реестра_" & Criterij    'имя новой книги
    'создаем новую книгу с одним листом
      Set WbN = Workbooks.Add(xlWBATWorksheet)
    'ставим автофильтр по столбцу C
          WCur.Range("C1").CurrentRegion.AutoFilter 3, Criterij
    'копируем видимые строки в новую книгу
        WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1")
        WCur.AutoFilter.Range.AutoFilter
         
        WbN.Sheets("Лист1").Columns("A:C").AutoFit
        WbN.SaveAs ThisWorkbook.Path & "\" & iName & ".xls"
        WbN.Close SaveChanges:=True
    Next
Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Kuzmich
Дата добавления - 04.12.2022 в 11:51
Leko Дата: Воскресенье, 04.12.2022, 15:58 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Все сработало, кроме сохранения. Но эту проблему решили.
Спасибо огромное.
 
Ответить
СообщениеВсе сработало, кроме сохранения. Но эту проблему решили.
Спасибо огромное.

Автор - Leko
Дата добавления - 04.12.2022 в 15:58
aladenskikhsergei Дата: Понедельник, 12.12.2022, 09:51 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Kuzmich, добрый день
Пользуюсь вашим макросом, все работает отлично, вспоминаю добрым словом каждый день.

Но возникли 2 вопроса:

1. макрос завершает свое выполнение ошибкой, т.к. в конце создает очередной файл, но копировать в него ему нечего и соотв. не может сохранить с определенным именем. можно ли как то сказать ему чтобы при создании файла по последнему условию из цикла, он просто завершал работу без ошибки?

2. пример:
В столбце E указаны названия магазинов, в остальных данные о платежных транзакциях. В ежедневных выгрузках разное число транзакций, и не всегда они есть по всем магазинам. Но есть 4 магазина данные по которым есть в каждой выгрузке.
Задача:
Используя макрос написанный вами выше, нужно также делить данные каждого магазина в отдельный файл, но, можно ли добавить исключение для 4 магазинов по следующему условию - "Маг 12 (оплата)" и "Маг 12 (возврат)" объеденить в 1 файл, вместо двух разных, и также "Маг 18 (оплата)" и "Маг 18 (возвраты)", названия изменил для примера. Названия менять нельзя, т.к. нам нужно видеть деление по оплате и возврату

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

Но возникли 2 вопроса:

1. макрос завершает свое выполнение ошибкой, т.к. в конце создает очередной файл, но копировать в него ему нечего и соотв. не может сохранить с определенным именем. можно ли как то сказать ему чтобы при создании файла по последнему условию из цикла, он просто завершал работу без ошибки?

2. пример:
В столбце E указаны названия магазинов, в остальных данные о платежных транзакциях. В ежедневных выгрузках разное число транзакций, и не всегда они есть по всем магазинам. Но есть 4 магазина данные по которым есть в каждой выгрузке.
Задача:
Используя макрос написанный вами выше, нужно также делить данные каждого магазина в отдельный файл, но, можно ли добавить исключение для 4 магазинов по следующему условию - "Маг 12 (оплата)" и "Маг 12 (возврат)" объеденить в 1 файл, вместо двух разных, и также "Маг 18 (оплата)" и "Маг 18 (возвраты)", названия изменил для примера. Названия менять нельзя, т.к. нам нужно видеть деление по оплате и возврату

Буду бесконечно благодарен, если у вас получится помочь

Автор - aladenskikhsergei
Дата добавления - 12.12.2022 в 09:51
Kuzmich Дата: Понедельник, 12.12.2022, 12:43 | Сообщение № 5
Группа: Проверенные
Ранг: Ветеран
Сообщений: 706
Репутация: 154 ±
Замечаний: 0% ±

Excel 2003
А где ваш пример?
 
Ответить
СообщениеА где ваш пример?

Автор - Kuzmich
Дата добавления - 12.12.2022 в 12:43
aladenskikhsergei Дата: Понедельник, 12.12.2022, 13:42 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

Kuzmich, добавил
К сообщению приложен файл: tmp1.xlsm(31.4 Kb)
 
Ответить
СообщениеKuzmich, добавил

Автор - aladenskikhsergei
Дата добавления - 12.12.2022 в 13:42
Kuzmich Дата: Понедельник, 12.12.2022, 14:26 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 706
Репутация: 154 ±
Замечаний: 0% ±

Excel 2003
Цитата
1. макрос завершает свое выполнение ошибкой,

Вы невнимательно скопировали мой макрос
[vba]
Код
   ' n = Cells(Rows.Count, "E").End(xlUp).Row
    n = Cells(Rows.Count, "V").End(xlUp).Row
[/vba]
Вновь создаваемая книга имеет один лист Лист1, а не Sheet1 (хотя м.б. у вас английская версия)
[vba]
Код
       ' WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Sheet1").Range("A1")
       WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1")
[/vba]
[vba]
Код
WbN.Sheets("Лист1").Columns("A:N").AutoFit
[/vba]


Сообщение отредактировал Kuzmich - Понедельник, 12.12.2022, 14:27
 
Ответить
Сообщение
Цитата
1. макрос завершает свое выполнение ошибкой,

Вы невнимательно скопировали мой макрос
[vba]
Код
   ' n = Cells(Rows.Count, "E").End(xlUp).Row
    n = Cells(Rows.Count, "V").End(xlUp).Row
[/vba]
Вновь создаваемая книга имеет один лист Лист1, а не Sheet1 (хотя м.б. у вас английская версия)
[vba]
Код
       ' WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Sheet1").Range("A1")
       WCur.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy WbN.Sheets("Лист1").Range("A1")
[/vba]
[vba]
Код
WbN.Sheets("Лист1").Columns("A:N").AutoFit
[/vba]

Автор - Kuzmich
Дата добавления - 12.12.2022 в 14:26
skais Дата: Среда, 14.12.2022, 12:05 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 213
Репутация: 27 ±
Замечаний: 20% ±

Excel 2010


Сообщение отредактировал skais - Среда, 14.12.2022, 12:06
 
Ответить
СообщениеГотовое решение

Автор - skais
Дата добавления - 14.12.2022 в 12:05
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создать из одной книги много по шаблону (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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