'списки фамилий Set Dic = CreateObject("Scripting.Dictionary") Populate fio1, ['Журнал ИБ'!K5], Dic Populate fiosklad1, ['Журнал ИБ'!L5], Dic Populate fiosklad2, ['Журнал ИБ'!R5], Dic Populate fio2, ['Журнал ИБ'!S5], Dic Populate ceh1, ['Журнал ИБ'!Q5], Dic Populate ceh2, ['Журнал ЗС'!H5], Dic Populate fio3, ['Журнал ИБ'!I5], Dic Populate fio4, ['Журнал ЗС'!J5], Dic Populate fio5, ['Журнал ЗС'!N5], Dic Populate fiosklad5, ['Журнал ЗС'!O5], Dic Set Dic = Nothing End Sub Private Sub Populate(ByRef ctrl As Control, ByRef Cell As Range, ByRef Dic As Object) Dim arr As Variant With Cell.Parent arr = .Range(Cell, .Cells(.Rows.Count, Cell.Column).End(xlUp)) End With If IsArray(arr) Then With Dic .RemoveAll For i = LBound(arr) To UBound(arr) .Item(arr(i, 1)) = 1 Next ctrl.List = .Keys End With Else ctrl.List = Array(arr) End If End Sub
'списки фамилий Set Dic = CreateObject("Scripting.Dictionary") Populate fio1, ['Журнал ИБ'!K5], Dic Populate fiosklad1, ['Журнал ИБ'!L5], Dic Populate fiosklad2, ['Журнал ИБ'!R5], Dic Populate fio2, ['Журнал ИБ'!S5], Dic Populate ceh1, ['Журнал ИБ'!Q5], Dic Populate ceh2, ['Журнал ЗС'!H5], Dic Populate fio3, ['Журнал ИБ'!I5], Dic Populate fio4, ['Журнал ЗС'!J5], Dic Populate fio5, ['Журнал ЗС'!N5], Dic Populate fiosklad5, ['Журнал ЗС'!O5], Dic Set Dic = Nothing End Sub Private Sub Populate(ByRef ctrl As Control, ByRef Cell As Range, ByRef Dic As Object) Dim arr As Variant With Cell.Parent arr = .Range(Cell, .Cells(.Rows.Count, Cell.Column).End(xlUp)) End With If IsArray(arr) Then With Dic .RemoveAll For i = LBound(arr) To UBound(arr) .Item(arr(i, 1)) = 1 Next ctrl.List = .Keys End With Else ctrl.List = Array(arr) End If End Sub
Sub Макрос1() With Application .EnableEvents = 0: .ScreenUpdating = 0 With ActiveSheet With .AutoFilter If .FilterMode Then .ShowAllData End With With .UsedRange With Intersect(.Cells, .Offset(2)) .Replace Date, "=zz1", 2, , , , False, False .Rows.Hidden = True End With End With End With With [zz1].Dependents .Rows.Hidden = False .Formula = Date End With .EnableEvents = 1: .ScreenUpdating = 1 End With End Sub
[/vba]
как-то так [vba]
Код
Sub Макрос1() With Application .EnableEvents = 0: .ScreenUpdating = 0 With ActiveSheet With .AutoFilter If .FilterMode Then .ShowAllData End With With .UsedRange With Intersect(.Cells, .Offset(2)) .Replace Date, "=zz1", 2, , , , False, False .Rows.Hidden = True End With End With End With With [zz1].Dependents .Rows.Hidden = False .Formula = Date End With .EnableEvents = 1: .ScreenUpdating = 1 End With End Sub
что то с заголовками столбцов макрос делает! переименовывает
Этнияоносамо [vba]
Код
Sub Макрос1() With Application .EnableEvents = 0: .ScreenUpdating = 0 With ActiveSheet If .FilterMode Then .ShowAllData With .UsedRange With Intersect(.Columns("N:O"), .Offset(1)) .Replace Date, "=zz1", 2, , , , False, False .Rows.Hidden = True End With End With End With With [zz1].DirectDependents .Rows.Hidden = False .Formula = Date End With .EnableEvents = 1: .ScreenUpdating = 1 End With End Sub
что то с заголовками столбцов макрос делает! переименовывает
Этнияоносамо [vba]
Код
Sub Макрос1() With Application .EnableEvents = 0: .ScreenUpdating = 0 With ActiveSheet If .FilterMode Then .ShowAllData With .UsedRange With Intersect(.Columns("N:O"), .Offset(1)) .Replace Date, "=zz1", 2, , , , False, False .Rows.Hidden = True End With End With End With With [zz1].DirectDependents .Rows.Hidden = False .Formula = Date End With .EnableEvents = 1: .ScreenUpdating = 1 End With End Sub
dt = Date + 1 With Application .EnableEvents = 0: .ScreenUpdating = 0 With ActiveSheet If .FilterMode Then .ShowAllData With .UsedRange With Intersect(.Cells, .Offset(2)) .Rows.Hidden = True If .Find(dt, , xlFormulas) Is Nothing Then GoTo x .Replace dt, "=zz1", 2, , , , False, False End With End With End With On Error Resume Next With [zz1].Dependents .Rows.Hidden = False .Formula = dt End With x: .EnableEvents = 1: .ScreenUpdating = 1 End With End Sub
[/vba]
тока дополз до компа, исчо одна поправка [vba]
Код
Sub Макрос1() Dim dt As Date
dt = Date + 1 With Application .EnableEvents = 0: .ScreenUpdating = 0 With ActiveSheet If .FilterMode Then .ShowAllData With .UsedRange With Intersect(.Cells, .Offset(2)) .Rows.Hidden = True If .Find(dt, , xlFormulas) Is Nothing Then GoTo x .Replace dt, "=zz1", 2, , , , False, False End With End With End With On Error Resume Next With [zz1].Dependents .Rows.Hidden = False .Formula = dt End With x: .EnableEvents = 1: .ScreenUpdating = 1 End With End Sub
Dim btn As Button Sub Уменьшить_размер_шрифта_на_кнопках() For Each btn In ActiveSheet.Buttons With btn.Font .Size = .Size - 1 End With Next End Sub Sub Увеличить_размер_шрифта_на_кнопках() For Each btn In ActiveSheet.Buttons With btn.Font .Size = .Size + 1 End With Next End Sub
[/vba]
И так тоже можно [vba]
Код
Dim btn As Button Sub Уменьшить_размер_шрифта_на_кнопках() For Each btn In ActiveSheet.Buttons With btn.Font .Size = .Size - 1 End With Next End Sub Sub Увеличить_размер_шрифта_на_кнопках() For Each btn In ActiveSheet.Buttons With btn.Font .Size = .Size + 1 End With Next End Sub
rRoute.Replace vbCrLf, vbLf rRoute.Replace vbLf, vbCrLf For Each rcell In rRoute If bNext Then lNext = rcell.Row: bNext = 0 If rcell = Me.Label1.Caption Then lRow = rcell.Row: bNext = 1 ii = ii + 1: If ii = rRoute.Count Then lLast = rcell.Row Next rcell
[/vba]
Здравствуйте, пробуйте так [vba]
Код
rRoute.Replace vbCrLf, vbLf rRoute.Replace vbLf, vbCrLf For Each rcell In rRoute If bNext Then lNext = rcell.Row: bNext = 0 If rcell = Me.Label1.Caption Then lRow = rcell.Row: bNext = 1 ii = ii + 1: If ii = rRoute.Count Then lLast = rcell.Row Next rcell