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

Вход

Регистрация

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

 

= Мир MS Excel/Преобразовать таблицу в список - Мир MS Excel

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

Excel 2010
Помогите пожалуйста решить следующую задачу.

Имеем таблицу данных, по горизонтали дни месяца, по вертикали объекты, на пересечении забиваем в ячейку руками сотрудника.
Необходимо:
1 На втором листе выводить эти данные построчно, как в примере. То есть искать в таблице не пустую ячейку и когда нашли, брать дату и объект и делать это новой строкой на листе2.
2 Самое сложное и важное! Если мы меняем в таблице лист1 уже существующую информацию (например удаляем Иванова), информация не должна пропадать из таблицы 2. То есть там должна быть история.

Надеюсь понятно написал.

Если первый пунк решаем формулами, то второй ставит меня в тупик.
К сообщению приложен файл: 8183290.xlsx(11Kb)
 
Ответить
СообщениеПомогите пожалуйста решить следующую задачу.

Имеем таблицу данных, по горизонтали дни месяца, по вертикали объекты, на пересечении забиваем в ячейку руками сотрудника.
Необходимо:
1 На втором листе выводить эти данные построчно, как в примере. То есть искать в таблице не пустую ячейку и когда нашли, брать дату и объект и делать это новой строкой на листе2.
2 Самое сложное и важное! Если мы меняем в таблице лист1 уже существующую информацию (например удаляем Иванова), информация не должна пропадать из таблицы 2. То есть там должна быть история.

Надеюсь понятно написал.

Если первый пунк решаем формулами, то второй ставит меня в тупик.

Автор - VVeps
Дата добавления - 20.04.2016 в 08:35
_Boroda_ Дата: Среда, 20.04.2016, 09:24 | Сообщение № 2
Группа: Модераторы
Ранг: Экселист
Сообщений: 9375
Репутация: 3948 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Такой простенький вариант в модуле первого листа. КодНайм второго обозван shIst
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim d_ As Range
    Application.ScreenUpdating = 0
    r0_ = 5
    r1_ = Range("A" & Rows.Count).End(xlUp).Row
    c0_ = 2
    c1_ = Cells(r0_ - 1, Columns.Count).End(xlToLeft).Column
    Set d_ = Intersect(Target, Range(Cells(r0_, c0_), Cells(r1_, c1_)))
    If Not d_ Is Nothing Then
        dc_ = d_.Cells.Count
        With shIst
            r11_ = .Range("A" & Rows.Count).End(xlUp).Row
            For i = 1 To dc_
                .Range("A" & r11_ + i) = Cells(r0_ - 1, d_(i).Column).Value
                .Range("B" & r11_ + i) = Cells(d_(i).Row, c0_ - 1).Value
                .Range("C" & r11_ + i) = d_(i).Value
            Next i
        End With
    End If
End Sub
[/vba]
К сообщению приложен файл: 8183290_1.xlsm(19Kb) · 1316178.gif(20Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеТакой простенький вариант в модуле первого листа. КодНайм второго обозван shIst
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim d_ As Range
    Application.ScreenUpdating = 0
    r0_ = 5
    r1_ = Range("A" & Rows.Count).End(xlUp).Row
    c0_ = 2
    c1_ = Cells(r0_ - 1, Columns.Count).End(xlToLeft).Column
    Set d_ = Intersect(Target, Range(Cells(r0_, c0_), Cells(r1_, c1_)))
    If Not d_ Is Nothing Then
        dc_ = d_.Cells.Count
        With shIst
            r11_ = .Range("A" & Rows.Count).End(xlUp).Row
            For i = 1 To dc_
                .Range("A" & r11_ + i) = Cells(r0_ - 1, d_(i).Column).Value
                .Range("B" & r11_ + i) = Cells(d_(i).Row, c0_ - 1).Value
                .Range("C" & r11_ + i) = d_(i).Value
            Next i
        End With
    End If
End Sub
[/vba]

Автор - _Boroda_
Дата добавления - 20.04.2016 в 09:24
krosav4ig Дата: Четверг, 21.04.2016, 00:27 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 1350
Репутация: 547 ±
Замечаний: 0% ±

Excel 2007, 2013
еще вариант
Сводная + подключение + небольшой макрос для обновления (в модуле Лист2)
[vba]
Код
Private Sub Worksheet_Activate()
    Dim LastRefreshed As Date
    With Sheets("Лист3").PivotTables(1)
        LastRefreshed = .RefreshDate: .RefreshTable
        Do While .RefreshDate <= LastRefreshed
            DoEvents
        Loop
    End With
    Me.ListObjects(1).QueryTable.Refresh 0
End Sub
[/vba]
К сообщению приложен файл: 8183290.xlsm(26Kb)


(_)Õvõ(_)
 
Ответить
Сообщениееще вариант
Сводная + подключение + небольшой макрос для обновления (в модуле Лист2)
[vba]
Код
Private Sub Worksheet_Activate()
    Dim LastRefreshed As Date
    With Sheets("Лист3").PivotTables(1)
        LastRefreshed = .RefreshDate: .RefreshTable
        Do While .RefreshDate <= LastRefreshed
            DoEvents
        Loop
    End With
    Me.ListObjects(1).QueryTable.Refresh 0
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 21.04.2016 в 00:27
VVeps Дата: Четверг, 21.04.2016, 08:58 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Спасибо большое! Как вы это делаете?

Boroda, можно вас попросить мемного изменить макрос под вновь окрывшиеся обстоятельста. Пример во вложении. Возникла необходимость добавить строчки. Теперь поиск фамилий нужно делать по каждой третьей строке начиная с пятой.
И огромная просьба, напишите короткие комментарии в макросе какая строка что делает. Я хочу понять макрос, пока не очень получилось :)

krosav4ig, спасибо, но под новый файл (во вложении), как я понимаю, метод со сводной таблицей не подходит.
К сообщению приложен файл: 3583260.xlsm(24Kb)
 
Ответить
СообщениеСпасибо большое! Как вы это делаете?

Boroda, можно вас попросить мемного изменить макрос под вновь окрывшиеся обстоятельста. Пример во вложении. Возникла необходимость добавить строчки. Теперь поиск фамилий нужно делать по каждой третьей строке начиная с пятой.
И огромная просьба, напишите короткие комментарии в макросе какая строка что делает. Я хочу понять макрос, пока не очень получилось :)

krosav4ig, спасибо, но под новый файл (во вложении), как я понимаю, метод со сводной таблицей не подходит.

Автор - VVeps
Дата добавления - 21.04.2016 в 08:58
_Boroda_ Дата: Четверг, 21.04.2016, 09:58 | Сообщение № 5
Группа: Модераторы
Ранг: Экселист
Сообщений: 9375
Репутация: 3948 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
можно вас попросить
Можно. Просите. :D

Такой вариант (с объяснялками). Пока писал их, понял, что немного лишнего наваял (одновременно и n, и f не обязательно), но ладно, так тоже нормально.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) 'При каждом изменении на листе
    Dim d_ As Range 'договариваемся, что d_ будет обозначением ячеек
    Application.ScreenUpdating = 0 'отключаем автообновление экрана
    r0_ = 5 'начальная строка
    r1_ = Range("B" & Rows.Count).End(xlUp).Row 'конечная строка по столбцу В
    c0_ = 3 'начальный столбец
    c1_ = Cells(r0_ - 1, Columns.Count).End(xlToLeft).Column 'конечный столбец по строке r0_-1 (4 строка)
    f_ = "ФИО" 'где будем ловить изменения
    n_ = 3 'кол-во строк в блоке (часы, машина, ФИО)
    Set d_ = Intersect(Target, Range(Cells(r0_, c0_), Cells(r1_, c1_))) 'пересечение С5:AG16 и того диапазона,
    'где мы изменили данные обзываем "d_" (сделано для возможности вводить сразу несколько строк и/или столбцов - например, копи-паст)
    If Not d_ Is Nothing Then 'если не d = пусто (другими словами - если d не пусто)
        dc_ = d_.Cells.Count 'кол-во ячеек в d
        With shIst 'для листа с кодовым именем shIst. Теперь его имя не пишем, а обозначаем первой точкой, вот так - .Range(что-то
            r11_ = .Range("A" & Rows.Count).End(xlUp).Row 'конечная строка по столбцу А
            For i = 1 To dc_ 'i меняется от 1 до dc и для каждого из i
                If Cells(d_(i).Row, c0_ - 1) = f_ Then 'если в той же строке и столбце В значение f, то
                    ii = ii + 1 'к счетчику ii прибавляем 1
                    .Range("A" & r11_ + ii) = Cells(r0_ - 1, d_(i).Column).Value 'в первой пустой ячейке столбца А листа shIst
                    'вставляем значение из строки 4 того столбца, где изменение на Лист1
                    .Range("B" & r11_ + ii) = Cells(d_(i).Row - n_ + 1, c0_ - 2).Value 'в первой пустой ячейке столбца В листа shIst
                    'вставляем значение из столбца А [строки с изменением минус 2], где изменение на Лист1
                    .Range("C" & r11_ + ii) = d_(i).Value 'в первой пустой ячейке столбца С листа shIst
                    'вставляем изменяемое значение из Лист1
                End If 'окончание второго ЕСЛИ
            Next i 'i становится i+1
        End With 'заканчиваем With по листу shIst
    End If 'окончание первого ЕСЛИ
End Sub 'окончание макроса
[/vba]
К сообщению приложен файл: 3583260_1.xlsm(20Kb)


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
Сообщение
можно вас попросить
Можно. Просите. :D

Такой вариант (с объяснялками). Пока писал их, понял, что немного лишнего наваял (одновременно и n, и f не обязательно), но ладно, так тоже нормально.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) 'При каждом изменении на листе
    Dim d_ As Range 'договариваемся, что d_ будет обозначением ячеек
    Application.ScreenUpdating = 0 'отключаем автообновление экрана
    r0_ = 5 'начальная строка
    r1_ = Range("B" & Rows.Count).End(xlUp).Row 'конечная строка по столбцу В
    c0_ = 3 'начальный столбец
    c1_ = Cells(r0_ - 1, Columns.Count).End(xlToLeft).Column 'конечный столбец по строке r0_-1 (4 строка)
    f_ = "ФИО" 'где будем ловить изменения
    n_ = 3 'кол-во строк в блоке (часы, машина, ФИО)
    Set d_ = Intersect(Target, Range(Cells(r0_, c0_), Cells(r1_, c1_))) 'пересечение С5:AG16 и того диапазона,
    'где мы изменили данные обзываем "d_" (сделано для возможности вводить сразу несколько строк и/или столбцов - например, копи-паст)
    If Not d_ Is Nothing Then 'если не d = пусто (другими словами - если d не пусто)
        dc_ = d_.Cells.Count 'кол-во ячеек в d
        With shIst 'для листа с кодовым именем shIst. Теперь его имя не пишем, а обозначаем первой точкой, вот так - .Range(что-то
            r11_ = .Range("A" & Rows.Count).End(xlUp).Row 'конечная строка по столбцу А
            For i = 1 To dc_ 'i меняется от 1 до dc и для каждого из i
                If Cells(d_(i).Row, c0_ - 1) = f_ Then 'если в той же строке и столбце В значение f, то
                    ii = ii + 1 'к счетчику ii прибавляем 1
                    .Range("A" & r11_ + ii) = Cells(r0_ - 1, d_(i).Column).Value 'в первой пустой ячейке столбца А листа shIst
                    'вставляем значение из строки 4 того столбца, где изменение на Лист1
                    .Range("B" & r11_ + ii) = Cells(d_(i).Row - n_ + 1, c0_ - 2).Value 'в первой пустой ячейке столбца В листа shIst
                    'вставляем значение из столбца А [строки с изменением минус 2], где изменение на Лист1
                    .Range("C" & r11_ + ii) = d_(i).Value 'в первой пустой ячейке столбца С листа shIst
                    'вставляем изменяемое значение из Лист1
                End If 'окончание второго ЕСЛИ
            Next i 'i становится i+1
        End With 'заканчиваем With по листу shIst
    End If 'окончание первого ЕСЛИ
End Sub 'окончание макроса
[/vba]

Автор - _Boroda_
Дата добавления - 21.04.2016 в 09:58
VVeps Дата: Четверг, 21.04.2016, 14:05 | Сообщение № 6
Группа: Пользователи
Ранг: Прохожий
Сообщений: 8
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Супер! hands

Благодаря подсказкам удалось встроить макрос в свой файл. Спасибо еще раз.
Вопрос для интереса, мы когда удаляем старые значения, макрос создает новые строки на листе shIst.
Я понимаю. что он работает при любых изменениях даипазона, но слишком ли сложно сделать, чтобы строки не создавались, если значение ячейки равно ="" (пусто)?????

В данном варианте я могу войти в ячейку и выйти ничего не меняя - будет новая строка.

В принципе и так работает, но перфикционизм, такой перфикционизм.
 
Ответить
СообщениеСупер! hands

Благодаря подсказкам удалось встроить макрос в свой файл. Спасибо еще раз.
Вопрос для интереса, мы когда удаляем старые значения, макрос создает новые строки на листе shIst.
Я понимаю. что он работает при любых изменениях даипазона, но слишком ли сложно сделать, чтобы строки не создавались, если значение ячейки равно ="" (пусто)?????

В данном варианте я могу войти в ячейку и выйти ничего не меняя - будет новая строка.

В принципе и так работает, но перфикционизм, такой перфикционизм.

Автор - VVeps
Дата добавления - 21.04.2016 в 14:05
_Boroda_ Дата: Четверг, 21.04.2016, 14:28 | Сообщение № 7
Группа: Модераторы
Ранг: Экселист
Сообщений: 9375
Репутация: 3948 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Еще условие добавьте во второй Иф. Или отдельным Ифом
[vba]
Код
If Cells(d_(i).Row, c0_ - 1) = f_ and d_(i)<>""  Then
[/vba]


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеЕще условие добавьте во второй Иф. Или отдельным Ифом
[vba]
Код
If Cells(d_(i).Row, c0_ - 1) = f_ and d_(i)<>""  Then
[/vba]

Автор - _Boroda_
Дата добавления - 21.04.2016 в 14:28
krosav4ig Дата: Пятница, 22.04.2016, 13:17 | Сообщение № 8
Группа: Друзья
Ранг: Старожил
Сообщений: 1350
Репутация: 547 ±
Замечаний: 0% ±

Excel 2007, 2013
под новый файл (во вложении), как я понимаю, метод со сводной таблицей не подходит.

Хто это вам такое сказал? ;)
К сообщению приложен файл: 8183290-2-.xlsm(37Kb)


(_)Õvõ(_)
 
Ответить
Сообщение
под новый файл (во вложении), как я понимаю, метод со сводной таблицей не подходит.

Хто это вам такое сказал? ;)

Автор - krosav4ig
Дата добавления - 22.04.2016 в 13:17
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Преобразовать таблицу в список (Макросы/Sub)
Страница 1 из 11
Поиск:

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