Скрытие ячеек при возрастающем количестве новых строк

Пользователь

Сообщений: 19 Регистрация: 01.01.1970

09.04.2018 12:26:33

Здравствуйте участники форума!

Поскольку давно не занимался с VBA, и надо восстанавливать знания, то обращаюсь к вам.

Возникла необходимость сделать макрос в Excel 2007, который бы оставлял три нижние строки по предприятию открытыми, а все остальные строки по предприятию скрывал.

Файл в приложении. В таблице есть небольшие комментарии. Количество столбцов урезано.

Вижу это следующим образом: цикл, в котором сначала проверяются количество количество одинаковых нескрытых ячеек в столбце "Предприятие". Если одинаковых ячеек больше 3, то верхние ячейки скрываются. Дальше происходит переход на следующие Предприятие.

Как это реализовать пока возникают некоторые сложности. Прошу помощи

Прикрепленные файлы

для форума.xlsx (9.97 КБ)

Юрий М Модератор Сообщений: 61037 Регистрация: 14.09.2012 Контакты см. в профиле	#2 09.04.2018 12:32:17 А если всего две строки будут с одной фирмой?

yozhik

Пользователь

Сообщений: 957 Регистрация: 01.01.1970

09.04.2018 12:49:37

предположу, что не скрываем..)

Код
Sub hd() For i = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1 If Cells(i, 2).Value = Cells(i + 1, 2).Value Then l = l + 1 Else l = 1 If l > 3 Then Rows(i).EntireRow.Hidden = True Next End Sub

Изменено: yozhik - 13.04.2018 22:58:53

Ігор Гончаренко

Пользователь

Сообщений: 14576 Регистрация: 01.01.1970

09.04.2018 12:53:27

Код

Sub Last3()
  Dim r&, c&, rg As Range
  r = 2
  Do While Not IsEmpty(Cells(r, 2))
    c = WorksheetFunction.CountIf(Columns(2), Cells(r, 2))
    If c > 3 Then
      If rg Is Nothing Then
        Set rg = Cells(r, 2).Resize(c - 3, 1)
      Else
        Set rg = Union(rg, Cells(r, 2).Resize(c - 3, 1))
      End If
    End If
    r = r + c
  Loop
  rg.EntireRow.Hidden = True
End Sub

Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!

Andrey A Пользователь Сообщений: 19 Регистрация: 01.01.1970	#5 13.04.2018 18:43:58 Спасибо большое за помощь!!! Искренне благодарен вам!!! Все работает!!!