crash173
Дата: Среда, 13.04.2022, 08:33 |
Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 16
Репутация:
0
±
Замечаний:
0% ±
2007
Доброе утро! Прошу помочь с макросом. Есть макрос, который применялся для другой таблицы. Макрос выполнял действие по фильтрации столбцов (горизонтально). Как можно применить его для моей таблицы, чтобы тоже была вертикальная фильтрация? Свой файл "post111" без макроса прилагаю. Отдельно макрос: [vba]Код
Option Explicit Public isHide As Boolean Sub ColumnHideShow() Dim rng As Range Dim i As Long, iRow As Long, iClm As Long Dim strKnopka As String If Cells.Count <> Cells.SpecialCells(xlCellTypeVisible).Count Then isHide = True Else: isHide = False End If 'пропускаем ошибки On Error Resume Next 'отключаем обновление и контроль событий Application.ScreenUpdating = False Application.EnableEvents = False 'снимаем текст в кнопке ' ActiveSheet.Shapes("AutoShape 2").Select ' strKnopka = Selection.Characters.Text ' Range("A1").Activate 'отображаем все столбцы If isHide = True Then ActiveSheet.Range(Cells(, 1), Cells(1, Columns.Count)).EntireColumn.Hidden = False strKnopka = "Скрыть столбцы" 'скрываем пустые столбцы в используемом диапазоне данных Else: With ActiveSheet.UsedRange iRow = .Row + .Rows.Count - 1 iClm = .Column + .Columns.Count - 1 .Range(Cells(1, 1), Cells(1, iClm)).EntireColumn.Hidden = False For i = iClm To 1 Step -1 Set rng = Range(Cells(1, i), Cells(Rows.Count, i)).Find(What:="?*", LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False) If rng Is Nothing Then .EntireColumn(i).Hidden = True Next i strKnopka = "Отобразить все" End With End If 'устанавливаем подпись кнопки ActiveSheet.Shapes("AutoShape 2").Select Selection.Characters.Text = strKnopka Range("A1").Activate Application.EnableEvents = True Application.ScreenUpdating = True End Sub '-------------------------------- 'Sub ShowAll() ' 'On Error Resume Next ' ' Application.ScreenUpdating = False ' Application.EnableEvents = False ' ' Range("B3").ClearContents ' 'Range(Cells(7, 6), Cells(7, Columns.Count)).EntireColumn.Hidden = False ' ' Application.EnableEvents = True ' Application.ScreenUpdating = True ' 'End Sub
[/vba]
Доброе утро! Прошу помочь с макросом. Есть макрос, который применялся для другой таблицы. Макрос выполнял действие по фильтрации столбцов (горизонтально). Как можно применить его для моей таблицы, чтобы тоже была вертикальная фильтрация? Свой файл "post111" без макроса прилагаю. Отдельно макрос: [vba]Код
Option Explicit Public isHide As Boolean Sub ColumnHideShow() Dim rng As Range Dim i As Long, iRow As Long, iClm As Long Dim strKnopka As String If Cells.Count <> Cells.SpecialCells(xlCellTypeVisible).Count Then isHide = True Else: isHide = False End If 'пропускаем ошибки On Error Resume Next 'отключаем обновление и контроль событий Application.ScreenUpdating = False Application.EnableEvents = False 'снимаем текст в кнопке ' ActiveSheet.Shapes("AutoShape 2").Select ' strKnopka = Selection.Characters.Text ' Range("A1").Activate 'отображаем все столбцы If isHide = True Then ActiveSheet.Range(Cells(, 1), Cells(1, Columns.Count)).EntireColumn.Hidden = False strKnopka = "Скрыть столбцы" 'скрываем пустые столбцы в используемом диапазоне данных Else: With ActiveSheet.UsedRange iRow = .Row + .Rows.Count - 1 iClm = .Column + .Columns.Count - 1 .Range(Cells(1, 1), Cells(1, iClm)).EntireColumn.Hidden = False For i = iClm To 1 Step -1 Set rng = Range(Cells(1, i), Cells(Rows.Count, i)).Find(What:="?*", LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False) If rng Is Nothing Then .EntireColumn(i).Hidden = True Next i strKnopka = "Отобразить все" End With End If 'устанавливаем подпись кнопки ActiveSheet.Shapes("AutoShape 2").Select Selection.Characters.Text = strKnopka Range("A1").Activate Application.EnableEvents = True Application.ScreenUpdating = True End Sub '-------------------------------- 'Sub ShowAll() ' 'On Error Resume Next ' ' Application.ScreenUpdating = False ' Application.EnableEvents = False ' ' Range("B3").ClearContents ' 'Range(Cells(7, 6), Cells(7, Columns.Count)).EntireColumn.Hidden = False ' ' Application.EnableEvents = True ' Application.ScreenUpdating = True ' 'End Sub
[/vba] crash173
Сообщение отредактировал Serge_007 - Среда, 13.04.2022, 09:06
Ответить
Сообщение Доброе утро! Прошу помочь с макросом. Есть макрос, который применялся для другой таблицы. Макрос выполнял действие по фильтрации столбцов (горизонтально). Как можно применить его для моей таблицы, чтобы тоже была вертикальная фильтрация? Свой файл "post111" без макроса прилагаю. Отдельно макрос: [vba]Код
Option Explicit Public isHide As Boolean Sub ColumnHideShow() Dim rng As Range Dim i As Long, iRow As Long, iClm As Long Dim strKnopka As String If Cells.Count <> Cells.SpecialCells(xlCellTypeVisible).Count Then isHide = True Else: isHide = False End If 'пропускаем ошибки On Error Resume Next 'отключаем обновление и контроль событий Application.ScreenUpdating = False Application.EnableEvents = False 'снимаем текст в кнопке ' ActiveSheet.Shapes("AutoShape 2").Select ' strKnopka = Selection.Characters.Text ' Range("A1").Activate 'отображаем все столбцы If isHide = True Then ActiveSheet.Range(Cells(, 1), Cells(1, Columns.Count)).EntireColumn.Hidden = False strKnopka = "Скрыть столбцы" 'скрываем пустые столбцы в используемом диапазоне данных Else: With ActiveSheet.UsedRange iRow = .Row + .Rows.Count - 1 iClm = .Column + .Columns.Count - 1 .Range(Cells(1, 1), Cells(1, iClm)).EntireColumn.Hidden = False For i = iClm To 1 Step -1 Set rng = Range(Cells(1, i), Cells(Rows.Count, i)).Find(What:="?*", LookIn:=xlFormulas, _ LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False) If rng Is Nothing Then .EntireColumn(i).Hidden = True Next i strKnopka = "Отобразить все" End With End If 'устанавливаем подпись кнопки ActiveSheet.Shapes("AutoShape 2").Select Selection.Characters.Text = strKnopka Range("A1").Activate Application.EnableEvents = True Application.ScreenUpdating = True End Sub '-------------------------------- 'Sub ShowAll() ' 'On Error Resume Next ' ' Application.ScreenUpdating = False ' Application.EnableEvents = False ' ' Range("B3").ClearContents ' 'Range(Cells(7, 6), Cells(7, Columns.Count)).EntireColumn.Hidden = False ' ' Application.EnableEvents = True ' Application.ScreenUpdating = True ' 'End Sub
[/vba] Автор - crash173 Дата добавления - 13.04.2022 в 08:33
crash173
Дата: Среда, 13.04.2022, 08:33 |
Сообщение № 2
Группа: Пользователи
Ранг: Новичок
Сообщений: 16
Репутация:
0
±
Замечаний:
0% ±
2007
исходник "post000" с макросом
Ответить
Сообщение исходник "post000" с макросом Автор - crash173 Дата добавления - 13.04.2022 в 08:33
crash173
Дата: Среда, 13.04.2022, 08:34 |
Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 16
Репутация:
0
±
Замечаний:
0% ±
2007
исходник без макроса "post001"
Ответить
Сообщение исходник без макроса "post001" Автор - crash173 Дата добавления - 13.04.2022 в 08:34