Страницы: 1
RSS
Скрытие строк на нескольких листах при помощи макроса, Скрытие строк на нескольких листах при помощи макроса
 
Доброго времени суток.Подскажите пожалуйста решение возникшей задачи. Имеются 2 листа в книге. При  определенных значения (условиях) необходимо скрыть строки/столбцы на этих листах. Строки/столбцы на листах могут быть как различные, так и одинаковые по номерам. Как сделать так, что бы при нажатии на кнопку, макрос скрывал строки/столбцы которые отмечены определенными знаками на обоих листах. Нашел на форуме тему про скрытие/отображение строк. Применил к книге, но скрывает только тот лист на котором находятся кнопки. То есть, на каждом листе своя конопка и скрывает/отображает строки только данного листа. В макросах ни чего не понимаю, начинаю только пытаться разбираться. Надеюсь на Вашу помощь. Заранее благодарю!
 
Добавьте цикл по всем листам, например так:
Код
Sub Skrytie()
    For n = 1 To Worksheets.Count
        If Worksheets(n).Name <> "Лист с кнопками" Then
        ''' сюда код скрытия ваших строк/столбцов
        End If
    Next n
End Sub
 
Код
Option Explicit

Const findWhat = "x"

Sub HideRows()
    FindInWb ActiveWorkbook
End Sub

Sub ShowRows()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        sh.UsedRange.EntireRow.Hidden = False
    Next
End Sub

Sub FindInWb(wb As Workbook)
    Dim sh As Worksheet
    For Each sh In wb.Worksheets
        FindInSheet sh
    Next
End Sub

Sub FindInSheet(sh As Worksheet)
    With sh.UsedRange
        Dim FoundCell As Range
        Dim LastCell As Range
        Dim FirstAddr As String
        Set LastCell = .Cells(.Rows.Count, .Columns.Count)
        Set FoundCell = .Find(what:=findWhat, after:=LastCell)
        
        If Not FoundCell Is Nothing Then
            FirstAddr = FoundCell.Address
        End If
        Do Until FoundCell Is Nothing
            FoundCellJob FoundCell
            Set FoundCell = .FindNext(after:=FoundCell)
            If FoundCell.Address = FirstAddr Then
                Exit Do
            End If
        Loop
    End With
End Sub

Sub FoundCellJob(cl As Range)
    cl.EntireRow.Hidden = True
End Sub
 
Огромное спасибо, работает, но есть одна проблема. Листов в книге около 100шт. На сколько я понял, макрос проверяет все листы...книга просто повисает. Как можно поправить код, что бы скрытие/отображение было применено к определенным листам. Я понимаю, что в коде нужно прописать имена/наименования листов, но как уже выше писал, в макросах пока что ни чего не понимаю, и не знаю, в какой строке прописать имена листов. Если не будет трудно, подскажите пожалуйста. Хотелось бы научиться работать с макросами)))). Заранее благодарю за помощь.
 
rumpelshtitchen, чуть дополнил макрос от Матроса. Прочитайте комментарий зелёным цветом в коде. Так же приложил файл с этим макросом

Код
Option Explicit
 
Const findWhat = "x"
 
Sub HideRows()
    FindInWb ActiveWorkbook
End Sub
 
Sub ShowRows()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        sh.UsedRange.EntireRow.Hidden = False
    Next
End Sub
 
Sub FindInWb(wb As Workbook)
    Dim sh As Worksheet
    Dim arrSheets As Variant
    Dim v As Variant
    
    'указываем названия листов в кавычках через запятую
    arrSheets = Array("Лист1", "Лист2")
    
    For Each v In arrSheets
        Set sh = wb.Worksheets(v)
        FindInSheet sh
    Next
End Sub
 
Sub FindInSheet(sh As Worksheet)
    With sh.UsedRange
        Dim FoundCell As Range
        Dim LastCell As Range
        Dim FirstAddr As String
        Set LastCell = .Cells(.Rows.Count, .Columns.Count)
        Set FoundCell = .Find(what:=findWhat, after:=LastCell)
         
        If Not FoundCell Is Nothing Then
            FirstAddr = FoundCell.Address
        End If
        Do Until FoundCell Is Nothing
            FoundCellJob FoundCell
            Set FoundCell = .FindNext(after:=FoundCell)
            If FoundCell.Address = FirstAddr Then
                Exit Do
            End If
        Loop
    End With
End Sub
 
Sub FoundCellJob(cl As Range)
    cl.EntireRow.Hidden = True
End Sub
Изменено: New - 12.06.2022 00:11:04
 
rumpelshtitchen, добрый день!

На листе "Лист с кнопками"

- Нажимете кнопку "Загрузить список листов"
Выбираете имена листов из списка справа
Нажимаете кнопку "Скрыть строки"
Критерий в коде (см. зеленый комментарий)
В приложенном файле скрываются строки, в ячейках которых есть буква "c" англ. раскладки.

Код
Private Sub CommandButton1_Click()
    Dim row_, i, arr(), j, lst, k, rows_arr
    j = 1
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) Then
        ReDim Preserve arr(1 To j)
        arr(j) = ListBox1.List(i): j = j + 1
    End If
Next i
With ThisWorkbook
If ListBox1.Selected(i - 1) = True Or UBound(arr) <> 0 Then
    For Each i In arr
        rows_arr = .Worksheets(i).UsedRange.Rows
            For lst = LBound(rows_arr, 1) To UBound(rows_arr, 1)
                k = Binary_Search_(ChoiceSort_(rows_arr, lst), "c") ' c меняем на значение строки которое нужно найти в строке на листе _
                которую нужно скрыть
                If k <> "" Then .Worksheets(i).Rows(lst).Hidden = True
            Next lst
    Next i
End If
End With

End Sub

Private Sub CommandButton2_Click()
    Dim i, arr(), j
    j = 1
    For Each i In ThisWorkbook.Worksheets
        If i.Name <> "Лист с кнопками" Then
            ReDim Preserve arr(1 To j)
            arr(j) = i.Name: j = j + 1
        End If
    Next i
    ListBox1.List = arr
End Sub
Private Function ChoiceSort_(myarr, c)
    Dim i, j, temp, tmp, NewArr(), k
    For i = LBound(myarr, 2) To UBound(myarr, 2)
        temp = i
        For j = i To UBound(myarr, 2)
            If myarr(c, j) < myarr(c, temp) Then temp = j
        Next j
        If temp <> i Then
        tmp = myarr(c, i)
        myarr(c, i) = myarr(c, temp)
        myarr(c, temp) = tmp
        End If
    Next i
    k = 1
    For i = LBound(myarr, 2) To UBound(myarr, 2)
        ReDim Preserve NewArr(1 To k)
        NewArr(k) = myarr(c, i)
        k = k + 1
    Next i
    ChoiceSort_ = NewArr
End Function
Private Function Binary_Search_(arr, what) As Variant
    Dim l As Long, h As Long
    Dim m As Long, item
    l = 0
    h = UBound(arr)
    
    While l <= h
        m = l + h
        If m = 0 Then
            Binary_Search_ = 0: Exit Function
        Else
            
            item = arr(m)
            If item = what Then Binary_Search_ = arr(m): Exit Function
            If item > what Then
                h = m - 1
            Else
                l = m + 1
            End If
        End If
    Wend
End Function
Изменено: artemkau88 - 12.06.2022 21:25:18
 
Добрый день! Не знаю здесь мне писать или отдельно создать тему? Мне необходимо во вложенном файле скрыть все строки с нулевыми значениями, удалять нельзя, так как все подтягивается формулами, в примере просто текстовый формат. Подскажите что можно придумать. Я так понимаю, что без макроса не сделать. Подскажите также с чего начать изучение макросов, в них я полный ноль
 
Арутюнян Михаил, добрый день!
Можно использовать тот же код (запускать по Alt+F8), немного изменил для Вашей задачи:
Код
Sub HideRows()
    Dim lst, k, rows_arr
Application.ScreenUpdating = False
    rows_arr = ActiveSheet.UsedRange.Rows
    For lst = LBound(rows_arr, 1) To UBound(rows_arr, 1)
        k = Binary_Search_(ChoiceSort_(rows_arr, lst), 0) ' c меняем на значение строки которое нужно найти в строке на листе _
        которую нужно скрыть
        If k <> "" Then ActiveSheet.Rows(lst).Hidden = True
    Next lst
Application.ScreenUpdating = True
End Sub
Private Function ChoiceSort_(myarr, c)
    Dim i, j, temp, tmp, NewArr(), k
    For i = LBound(myarr, 2) To UBound(myarr, 2)
        temp = i
        For j = i To UBound(myarr, 2)
            If myarr(c, j) < myarr(c, temp) Then temp = j
        Next j
        If temp <> i Then
        tmp = myarr(c, i)
        myarr(c, i) = myarr(c, temp)
        myarr(c, temp) = tmp
        End If
    Next i
    k = 1
    For i = LBound(myarr, 2) To UBound(myarr, 2)
        ReDim Preserve NewArr(1 To k)
        NewArr(k) = myarr(c, i)
        k = k + 1
    Next i
    ChoiceSort_ = NewArr
End Function
Private Function Binary_Search_(arr, what) As Variant
    Dim l As Long, h As Long
    Dim m As Long, item
    l = 0
    h = UBound(arr)
    
    While l <= h
        m = l + h
        If m = 0 Then
            Binary_Search_ = 0: Exit Function
        Else
            
            item = arr(m)
            If item = what Then Binary_Search_ = arr(m): Exit Function
            If item > what Then
                h = m - 1
            Else
                l = m + 1
            End If
        End If
    Wend
End Function
Вышеуказанный код ищет первое вхождение 0 во всей строке независимо от столбца
Если нужно скрывать строки по значению определенного столбца (в примере столбец AH) равными 0 то:
Код
Sub HideRows_2()
    Dim lst, k, rows_arr
Application.ScreenUpdating = False
    rows_arr = ActiveSheet.UsedRange.Rows
    For lst = LBound(rows_arr, 1) To UBound(rows_arr, 1)
        If rows_arr(lst, 34) = 0 Then ActiveSheet.Rows(lst).Hidden = True
    Next lst
Application.ScreenUpdating = True
End Sub
Изменено: artemkau88 - 13.06.2022 09:58:23
 
Друзья, большое спасибо за помощь, не мог поблагодарить Вас за участие в данной теме. Отдельное спасибо artemkau88, Ваш вариант очень интересный, и он нашел свое применение в решении другого вопроса. Вариант New полностью подходит для решения изначально поставленной задачи, но при "ковырянии" листа и подстановкой макроса, столкнулся со следующей проблемой. Если, использовать формулы "ЕСЛИ", макрос скрывает все строки, где имеется условие, в нашем случае "X". ...Возможно ли, как то, "подправить" макрос, который предложил New????...Еще раз прошу прощения за назойливость, пытаюсь сам разобраться в кодах макроса, но идет тяжеловато....Пример приложил.
Страницы: 1
Наверх