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

Вход

Регистрация

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

 

= Мир MS Excel/Макрос для создания реестра по данным из ячеек - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос для создания реестра по данным из ячеек (Макросы/Sub)
Макрос для создания реестра по данным из ячеек
Webbear Дата: Вторник, 27.09.2016, 15:05 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 34
Репутация: 2 ±
Замечаний: 0% ±

Excel 2010
Добрый день. Столкнулся с проблемой.
Существует книга с любым количеством листов, имеющих в каждой новой книге разные названия. Листы представляют из себя форму акта.
Каждая новая книга имеет листы с новым наименованием, либо вообще без оного. На каждом листе часть данных повторяется, а часть меняется (напр.: Акт освидетельствования скрытых работ № - постоянно, сам номер в отдельной ячейке и естественно неповторим, наименование работ, содержащееся в определенном диапазоне ячеек, и дата аналогично.
Нужен универсальный макрос, который:
1. Создаст новый лист с названием "Реестр"
2. В этом листе создаст список из 2-х столбцов:
а). Сцепка фраз из ячеек каждого листа в новой строке "АКТ освидетельствования скрытых работ ХХХ Наименование работ (каждый цвет - это определенная ячейка в листе)
б). чч. мм.гггг
Макрос должен быть универсальным, обновлять реестр при добавлении и удалении листов и не реагировать на их переименование.
Каждая новая строка в реестре берется из следующего листа.
Отдаленный пример того что должно получиться в приложении.
К сообщению приложен файл: ___-2_.xlsm(79Kb)
 
Ответить
СообщениеДобрый день. Столкнулся с проблемой.
Существует книга с любым количеством листов, имеющих в каждой новой книге разные названия. Листы представляют из себя форму акта.
Каждая новая книга имеет листы с новым наименованием, либо вообще без оного. На каждом листе часть данных повторяется, а часть меняется (напр.: Акт освидетельствования скрытых работ № - постоянно, сам номер в отдельной ячейке и естественно неповторим, наименование работ, содержащееся в определенном диапазоне ячеек, и дата аналогично.
Нужен универсальный макрос, который:
1. Создаст новый лист с названием "Реестр"
2. В этом листе создаст список из 2-х столбцов:
а). Сцепка фраз из ячеек каждого листа в новой строке "АКТ освидетельствования скрытых работ ХХХ Наименование работ (каждый цвет - это определенная ячейка в листе)
б). чч. мм.гггг
Макрос должен быть универсальным, обновлять реестр при добавлении и удалении листов и не реагировать на их переименование.
Каждая новая строка в реестре берется из следующего листа.
Отдаленный пример того что должно получиться в приложении.

Автор - Webbear
Дата добавления - 27.09.2016 в 15:05
devilkurs Дата: Вторник, 27.09.2016, 15:13 | Сообщение № 2
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 140
Репутация: 37 ±
Замечаний: 0% ±

Excel 2007, 2010
Webbear, добрый день

Вопрос: Всегда ли "АКТ освидетельствования скрытых работ" начинается с 48 строки? И соответственно № и дата всегда ли находится на 51 строке?


 
Ответить
СообщениеWebbear, добрый день

Вопрос: Всегда ли "АКТ освидетельствования скрытых работ" начинается с 48 строки? И соответственно № и дата всегда ли находится на 51 строке?

Автор - devilkurs
Дата добавления - 27.09.2016 в 15:13
Webbear Дата: Вторник, 27.09.2016, 15:18 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 34
Репутация: 2 ±
Замечаний: 0% ±

Excel 2010
Да, всегда.
 
Ответить
СообщениеДа, всегда.

Автор - Webbear
Дата добавления - 27.09.2016 в 15:18
devilkurs Дата: Вторник, 27.09.2016, 15:35 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 140
Репутация: 37 ±
Замечаний: 0% ±

Excel 2007, 2010
Webbear,
В таком виде: (кнопка на листе Реестр)
К сообщению приложен файл: -2_.xlsm(89Kb)




Сообщение отредактировал devilkurs - Вторник, 27.09.2016, 15:35
 
Ответить
СообщениеWebbear,
В таком виде: (кнопка на листе Реестр)

Автор - devilkurs
Дата добавления - 27.09.2016 в 15:35
Webbear Дата: Вторник, 27.09.2016, 15:42 | Сообщение № 5
Группа: Пользователи
Ранг: Новичок
Сообщений: 34
Репутация: 2 ±
Замечаний: 0% ±

Excel 2010
Гениально!!!!
А чтобы дату в формате чч.мм.гггг записать?
И если листа реестр изначально нет, при запуске макроса вылазит косяк.


Сообщение отредактировал Webbear - Вторник, 27.09.2016, 15:48
 
Ответить
СообщениеГениально!!!!
А чтобы дату в формате чч.мм.гггг записать?
И если листа реестр изначально нет, при запуске макроса вылазит косяк.

Автор - Webbear
Дата добавления - 27.09.2016 в 15:42
devilkurs Дата: Вторник, 27.09.2016, 16:17 | Сообщение № 6
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 140
Репутация: 37 ±
Замечаний: 0% ±

Excel 2007, 2010
Webbear,
Надеюсь у Вас не более 100 листов будет )))))
К сообщению приложен файл: 1759179.xlsm(88Kb)




Сообщение отредактировал devilkurs - Вторник, 27.09.2016, 16:18
 
Ответить
СообщениеWebbear,
Надеюсь у Вас не более 100 листов будет )))))

Автор - devilkurs
Дата добавления - 27.09.2016 в 16:17
МВТ Дата: Вторник, 27.09.2016, 16:30 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 475
Репутация: 135 ±
Замечаний: 0% ±

Excel 2007
devilkurs, мне кажется так будет несколько проще (взял за основу Ваш первый код, изменения формата даты не переносил)
[vba]
Код
Sub Реестр()
    Dim i%, Sh As Worksheet, rSh As Worksheet
    Application.ScreenUpdating = False
    On Error Resume Next
    Set rSh = Sheets("Реестр")
    If Err Then
        Err.Clear
        Set rSh = Sheets.Add
        rSh.Name = "Реестр"
    Else
        With rSh
            .Activate
            .UsedRange.Clear 'Очистим лист Реестр
        End With
    End If
    i = 1
    For Each Sh In Sheets 'Перебираем все имеющиеся листы в Книге
        If Sh.Name <> "Реестр" Then
            i = i + 1
            With Sh
                Cells(i, 1) = .Range("A48") & " " & .Range("A49") & " № " & .Range("B51") & " " & .Range("T82") & " " & .Range("A83")
                Cells(i, 2) = .Range("U51") & " " & .Range("X51") & " " & .Range("AC51")
            End With
        End If
    Next Sh
    rSh.Columns("A:B").AutoFit
    Application.ScreenUpdating = True
End Sub
[/vba]
 
Ответить
Сообщениеdevilkurs, мне кажется так будет несколько проще (взял за основу Ваш первый код, изменения формата даты не переносил)
[vba]
Код
Sub Реестр()
    Dim i%, Sh As Worksheet, rSh As Worksheet
    Application.ScreenUpdating = False
    On Error Resume Next
    Set rSh = Sheets("Реестр")
    If Err Then
        Err.Clear
        Set rSh = Sheets.Add
        rSh.Name = "Реестр"
    Else
        With rSh
            .Activate
            .UsedRange.Clear 'Очистим лист Реестр
        End With
    End If
    i = 1
    For Each Sh In Sheets 'Перебираем все имеющиеся листы в Книге
        If Sh.Name <> "Реестр" Then
            i = i + 1
            With Sh
                Cells(i, 1) = .Range("A48") & " " & .Range("A49") & " № " & .Range("B51") & " " & .Range("T82") & " " & .Range("A83")
                Cells(i, 2) = .Range("U51") & " " & .Range("X51") & " " & .Range("AC51")
            End With
        End If
    Next Sh
    rSh.Columns("A:B").AutoFit
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - МВТ
Дата добавления - 27.09.2016 в 16:30
devilkurs Дата: Вторник, 27.09.2016, 16:34 | Сообщение № 8
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 140
Репутация: 37 ±
Замечаний: 0% ±

Excel 2007, 2010
МВТ, О! через обработчик ошибок ))) Отлично! А я никак не научу себя его использовать )))

Код МВТ + преобразование даты




Сообщение отредактировал devilkurs - Вторник, 27.09.2016, 16:38
 
Ответить
СообщениеМВТ, О! через обработчик ошибок ))) Отлично! А я никак не научу себя его использовать )))

Код МВТ + преобразование даты

Автор - devilkurs
Дата добавления - 27.09.2016 в 16:34
Webbear Дата: Вторник, 27.09.2016, 16:39 | Сообщение № 9
Группа: Пользователи
Ранг: Новичок
Сообщений: 34
Репутация: 2 ±
Замечаний: 0% ±

Excel 2010
Всем огромнейшее СПАСИБО!!!!
Все заработало как надо.
Тему можно закрывать. hands
 
Ответить
СообщениеВсем огромнейшее СПАСИБО!!!!
Все заработало как надо.
Тему можно закрывать. hands

Автор - Webbear
Дата добавления - 27.09.2016 в 16:39
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос для создания реестра по данным из ячеек (Макросы/Sub)
Страница 1 из 11
Поиск:

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