Новости:

Теперь на форум можно залогиниться / зарегистрироваться с помощью ВКонтакте. Уже существующие пользователи могут связать свою учетную запись с аккаунтом ВКонтакте одним кликом в профиле пользователя http://forum.msexcel.ru/index.php?action=profile;area=account

Главное меню

помогите доработать макросы (скрыть/отоброзить строки)

Автор Anyuta, 16.12.2013, 19:14

« назад - далее »

Anyuta

Помогите пожалуйста доработать макросы!

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

Нужно что бы в "Диапазоне_данных" проверялся цвет каждой ячейки в строке
Если там есть хотя бы одна ячейка заданного цвета (голубого) то эта строка отображалась
иначе - скрывалась
Т.е. отображались только строки удовлетворяющие условию, все остальные скрывались,
и соответсвенно если до этого уже применялся другой макрос на сокрытие строк, надо что бы перед тем как макрос начал проверять строки, он сначала все строки отобразил, что бы не получилось что ранее скрытая строка (возможно удовлетворяет условию, но так она уже была скрыта то она и не отоброзится)

вот недоваренный макрос:

Sub Отоброзить_ячейки_голубого_цвета()
    Dim cell As Range
    Application.ScreenUpdating = False                                      'отключаем обновление экрана для ускорения
    For Each cell In ActiveSheet.Range("Диапазон_данных").Cells                     'проходим по всем ячейкам первого столбца
        If cell.Interior.ColorIndex = 8 Then cell.EntireRow.Hidden = False   'если ячейка в диапазоне заданного цвета - отоброжаем строку
    Next
    Application.ScreenUpdating = True
End Sub


И нужен еще один почти такой же на условие что если в "диапазоне_данных" в строке есть хоть одна ячейка голубого цвета и хоть одна ячейка красного цвета она отображалась, все остальные скрывались.

RAN

Чтой-то мне кажется, что эта "хоть одна ячейка голубого цвета " красится УФ.

kuklp

Мне кажется, что я ослеп:
ЦитироватьВ приложении файл
Я, как всегда, чертовски адекватен... Email: pilipnikop@yandex.ua WM Z206653985942, R334086032478, U238399322728, E332314026771

Anyuta

извиняюсь, файл добавила

нет не УФ, заливка делается вручную

RAN

Sub Мяу()
Application.ScreenUpdating = False
    [A5].CurrentRegion.Rows.Hidden = False
    For Each rw In [A5].CurrentRegion.Rows
        For Each cl In rw.Cells
            Select Case cl.Interior.Color
            Case 16776997, 2960895
                cl.EntireRow.Hidden = True
                Exit For
            End Select
        Next
    Next
End Sub

Anyuta

#5
RAN, макрос скрывает нужные ячейки, надо что бы отображал только их и скрывал все остальное
и надо именно чтобы макрос работал только в "диапазоне_данных", т.е. ниже и выше пойдут другие данные с которыми макрос не должен никак работать

на скрытие нужных ячеек я собрала с горем пополам макрос

Sub Скрыть_ячейки_голубого_цвета()
    Dim cell As Range
    Application.ScreenUpdating = False
    For Each cell In ActiveSheet.Range("Диапазон_данных").Cells
        If cell.Interior.ColorIndex = 8 Then cell.EntireRow.Hidden = True
    Next
    Application.ScreenUpdating = True
End Sub


мне нужно отредактировать тут
1) как прописать что бы сперва "диапазон данных" полностью отобразился? (что бы ни пропали скрытые ранее строки)
2)  изменить
If cell.Interior.ColorIndex = 8 Then cell.EntireRow.Hidden = False
else ... (иначе скрыть строку)


по возможности, видоизменяйте выложенный макрос, потому что я профан в VB, что бы мне аналогично собрать макрос с некоторыми другими условиями не пришлось изучать весь VB

Anyuta, оформляйте код тегами! [Модератор]

RAN

#6
Sub Мяу()
    Application.ScreenUpdating = False
    [A6].CurrentRegion.Rows.Hidden = False
    For Each rw In [A6].CurrentRegion.Rows
        For Each cl In rw.Cells
            Select Case cl.Interior.Color
            Case 16776997, 2960895
                flag = True
                Exit For
            End Select
        Next
        If flag = False Then rw.EntireRow.Hidden = True
        flag = False
    Next
End Sub

Anyuta

RAN спасибо, но это не совсем то что нужно, он работает у меня по всему документу, т.е. скрывает мне и шапку и хвост, мне надо что бы только в определенном диапазоне С8:AD1204 т.к. будут добавляться новые строки, я так понимаю что нужно задать имя диапазону, или я что то неверно понимаю?

и он отоброжает строку если в ней хотя бы одна ячейка заданного цвета,
а в случае с двумя цветами, надо что бы в строке были обязательно оба цвета, а не либо одно либо другое

RAN

Sub Мяу()
    Application.ScreenUpdating = False
    '    With Range("Диапазон_данных")    ' можно и так
    With [A6].CurrentRegion.Offset(2).Resize([A6].CurrentRegion.Rows.Count - 3)
        .Rows.Hidden = False
        For Each rw In .Rows
            For Each cl In rw.Cells
                Select Case cl.Interior.Color
                Case 16776997
                    flag1 = 1
                Case 2960895
                    flag2 = 1
                End Select
            Next
            If flag1 + flag2 < 2 Then rw.EntireRow.Hidden = True
            flag1 = 0: flag2 = 0
        Next
    End With
End Sub


Anyuta

#9
RAN спасибо наиогроменнейшее! все работает  :)
Два вопроса еще
1) в какой системе у вас кодировка цвета? я че то никак не сооброжу как мне остальные цвета прописать, мне просто такой же макрос нужен будет на желтый, зеленый, коричневый и без заливки
2) макрос на один цвет для нужного мне диапазона выглядит так?
Sub Мяу()
    Application.ScreenUpdating = False
    With Range("Диапазон_данных")    ' можно и так
         .Rows.Hidden = False
       For Each rw In .Rows
        For Each cl In rw.Cells
            Select Case cl.Interior.Color
            Case 2960895
                flag = True
                Exit For
            End Select
        Next
        If flag = False Then rw.EntireRow.Hidden = True
        flag = False
    Next
  End With
End Sub

RAN

1. Понятия не имею
Закрасьте ячейки и выполните макрос
ActiveCell.Value = Val(ActiveCell.Interior.Color)
Без заливки
cl.Interior.Pattern = xlNone
2. Так.

Anyuta

Спасибо, разобралась с цветами, все отлично работает!  :)