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

Вход

Регистрация

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

 

= Мир MS Excel/Создание реестра по условию - Мир MS Excel

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

Всем привет!
Прошу помощи!
Дано: лист "list1" с определенными данными и значениями.
Что нужно: чтобы в листе "panel" автоматически создался реестр с данными из листа "list1" только из значений, которые в столбе "Чекбокс" имеют значение "1".
Заранее спасибо за помощь!
К сообщению приложен файл: reesr.xlsx (10.1 Kb)
 
Ответить
СообщениеВсем привет!
Прошу помощи!
Дано: лист "list1" с определенными данными и значениями.
Что нужно: чтобы в листе "panel" автоматически создался реестр с данными из листа "list1" только из значений, которые в столбе "Чекбокс" имеют значение "1".
Заранее спасибо за помощь!

Автор - CaHDaJIb
Дата добавления - 03.08.2022 в 09:53
pechkin Дата: Среда, 03.08.2022, 10:26 | Сообщение № 2
Группа: Проверенные
Ранг: Обитатель
Сообщений: 329
Репутация: 49 ±
Замечаний: 0% ±

2003
Здравствуйте![vba]
Код
Sub Макрос1()
       Dim iLastRow As Long, rw As Long
       Dim i As Integer
    Range("B4:D22").ClearContents
   With Sheets("list1")
   iLastRow = .Cells(Rows.Count, 3).End(xlUp).Row
     rw = 4
   For i = 3 To iLastRow
  If .Cells(i, 2).Value = 1 Then
  Cells(rw, 2).Resize(, 3).Value = .Cells(i, 3).Resize(, 3).Value
  rw = rw + 1
  End If
         Next
   End With
  End Sub
[/vba]
К сообщению приложен файл: reesr_.xls (43.5 Kb)
 
Ответить
СообщениеЗдравствуйте![vba]
Код
Sub Макрос1()
       Dim iLastRow As Long, rw As Long
       Dim i As Integer
    Range("B4:D22").ClearContents
   With Sheets("list1")
   iLastRow = .Cells(Rows.Count, 3).End(xlUp).Row
     rw = 4
   For i = 3 To iLastRow
  If .Cells(i, 2).Value = 1 Then
  Cells(rw, 2).Resize(, 3).Value = .Cells(i, 3).Resize(, 3).Value
  rw = rw + 1
  End If
         Next
   End With
  End Sub
[/vba]

Автор - pechkin
Дата добавления - 03.08.2022 в 10:26
msi2102 Дата: Среда, 03.08.2022, 10:29 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
Если у Вас офис 2019 и выше то можно формулой
Код
=ФИЛЬТР(list1!C3:E18;list1!B3:B18)
К сообщению приложен файл: 5301126.xlsx (11.8 Kb)
 
Ответить
СообщениеЕсли у Вас офис 2019 и выше то можно формулой
Код
=ФИЛЬТР(list1!C3:E18;list1!B3:B18)

Автор - msi2102
Дата добавления - 03.08.2022 в 10:29
Nic70y Дата: Среда, 03.08.2022, 10:40 | Сообщение № 4
Группа: Друзья
Ранг: Экселист
Сообщений: 8703
Репутация: 2258 ±
Замечаний: 0% ±

Excel 2010
варианты:
формула "старая" (с доп.яч. - красная)
Код
=ЕСЛИОШИБКА(ИНДЕКС(list1!$C$1:$C$9999;ПОИСКПОЗ(1;ИНДЕКС(list1!$B$1:$B$9999;ПОИСКПОЗ(B3;list1!$C$1:$C$9999;)+1):list1!$B$9999;)+ПОИСКПОЗ(B3;list1!$C$1:$C$9999;));"")
далее ВПР
макрос (цикл только по 1)
[vba]
Код
Sub u_814()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "a").End(xlUp).Row
    If a > 3 Then Range("a4:d" & a).Clear
    b = Sheets("list1").Cells(Rows.Count, "b").End(xlUp).Row
    c = Application.Sum(Sheets("list1").Range("b3:b" & b))  'кол-во 1
    If c > 0 Then
        d = 3 'строка, с которой ищем след. 1
        For e = 1 To c
            f = Application.Match(1, Sheets("list1").Range("b" & d & ":b" & b), 0)
            g = Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки
            d = d + f
            Sheets("list1").Range("b" & d - 1 & ":e" & d - 1).Copy Range("a" & g)
            Range("a" & g) = e
        Next
    End If
    Application.ScreenUpdating = True
End Sub
[/vba]
К сообщению приложен файл: formula.xlsx (13.0 Kb) · macro.xlsm (21.2 Kb)


ЮMoney 41001841029809

Сообщение отредактировал Nic70y - Среда, 03.08.2022, 10:45
 
Ответить
Сообщениеварианты:
формула "старая" (с доп.яч. - красная)
Код
=ЕСЛИОШИБКА(ИНДЕКС(list1!$C$1:$C$9999;ПОИСКПОЗ(1;ИНДЕКС(list1!$B$1:$B$9999;ПОИСКПОЗ(B3;list1!$C$1:$C$9999;)+1):list1!$B$9999;)+ПОИСКПОЗ(B3;list1!$C$1:$C$9999;));"")
далее ВПР
макрос (цикл только по 1)
[vba]
Код
Sub u_814()
    Application.ScreenUpdating = False
    a = Cells(Rows.Count, "a").End(xlUp).Row
    If a > 3 Then Range("a4:d" & a).Clear
    b = Sheets("list1").Cells(Rows.Count, "b").End(xlUp).Row
    c = Application.Sum(Sheets("list1").Range("b3:b" & b))  'кол-во 1
    If c > 0 Then
        d = 3 'строка, с которой ищем след. 1
        For e = 1 To c
            f = Application.Match(1, Sheets("list1").Range("b" & d & ":b" & b), 0)
            g = Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки
            d = d + f
            Sheets("list1").Range("b" & d - 1 & ":e" & d - 1).Copy Range("a" & g)
            Range("a" & g) = e
        Next
    End If
    Application.ScreenUpdating = True
End Sub
[/vba]

Автор - Nic70y
Дата добавления - 03.08.2022 в 10:40
CaHDaJIb Дата: Среда, 03.08.2022, 10:58 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Ух, всем спасибо, плюсанул!
я так понимаю что самое действенное поставить офис 2019 и работать с простой формулой?
 
Ответить
СообщениеУх, всем спасибо, плюсанул!
я так понимаю что самое действенное поставить офис 2019 и работать с простой формулой?

Автор - CaHDaJIb
Дата добавления - 03.08.2022 в 10:58
Nic70y Дата: Среда, 03.08.2022, 11:25 | Сообщение № 6
Группа: Друзья
Ранг: Экселист
Сообщений: 8703
Репутация: 2258 ±
Замечаний: 0% ±

Excel 2010
я так понимаю что самое действенное поставить офис 2019 и работать с простой формулой?
поставить новый офис - это хорошо, в любом случае.
2013 мне нравился больше чем 2010, но работа...
а на счет простой формулы - она не простая, а массивная, тут нужно смотреть по обстоятельствам.


ЮMoney 41001841029809
 
Ответить
Сообщение
я так понимаю что самое действенное поставить офис 2019 и работать с простой формулой?
поставить новый офис - это хорошо, в любом случае.
2013 мне нравился больше чем 2010, но работа...
а на счет простой формулы - она не простая, а массивная, тут нужно смотреть по обстоятельствам.

Автор - Nic70y
Дата добавления - 03.08.2022 в 11:25
msi2102 Дата: Среда, 03.08.2022, 11:27 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 413
Репутация: 129 ±
Замечаний: 0% ±

Excel 2007
она не простая, а массивная
Если 2019 с LTSC то простая, поэтому всегда забываю писать, что она массивная
К сообщению приложен файл: 9341203.png (22.5 Kb)


Сообщение отредактировал msi2102 - Среда, 03.08.2022, 11:35
 
Ответить
Сообщение
она не простая, а массивная
Если 2019 с LTSC то простая, поэтому всегда забываю писать, что она массивная

Автор - msi2102
Дата добавления - 03.08.2022 в 11:27
Nic70y Дата: Среда, 03.08.2022, 11:48 | Сообщение № 8
Группа: Друзья
Ранг: Экселист
Сообщений: 8703
Репутация: 2258 ±
Замечаний: 0% ±

Excel 2010
msi2102, я не вводе формулы.
не могу судить о ее "тяжести", по этому и написал
нужно смотреть по обстоятельствам


ЮMoney 41001841029809
 
Ответить
Сообщениеmsi2102, я не вводе формулы.
не могу судить о ее "тяжести", по этому и написал
нужно смотреть по обстоятельствам

Автор - Nic70y
Дата добавления - 03.08.2022 в 11:48
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Создание реестра по условию (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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