Друзья-товарищи! Нужен макрос добавляющий строки в конце форматированной таблицы при условии заполнения любой ячейки в ближайшей свободной строке. И все это когда лист защищен
Друзья-товарищи! Нужен макрос добавляющий строки в конце форматированной таблицы при условии заполнения любой ячейки в ближайшей свободной строке. И все это когда лист защищен Leprotto
Leprotto, у Вас сама таблица защищена, как ее изменять?) В формате ячеек убрала "защищаемая ячейка" с диапазона таблицы. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set r = Intersect(Target, Range("Таблица1")) If Not r Is Nothing Then Application.EnableEvents = False ActiveSheet.Unprotect "1" lr = [a1].CurrentRegion.Rows.Count ActiveSheet.ListObjects("Таблица1").Resize Range("a1:g" & lr + 3) ActiveSheet.Protect "1" Application.EnableEvents = True End If End Sub
[/vba] KuklP, в ячейке I2 указан пароль(1)
Leprotto, у Вас сама таблица защищена, как ее изменять?) В формате ячеек убрала "защищаемая ячейка" с диапазона таблицы. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set r = Intersect(Target, Range("Таблица1")) If Not r Is Nothing Then Application.EnableEvents = False ActiveSheet.Unprotect "1" lr = [a1].CurrentRegion.Rows.Count ActiveSheet.ListObjects("Таблица1").Resize Range("a1:g" & lr + 3) ActiveSheet.Protect "1" Application.EnableEvents = True End If End Sub
[/vba] KuklP, в ячейке I2 указан пароль(1) Manyasha
ActiveSheet.ListObjects("Таблица1").Resize Range("a1:g" & lr + 3)
Если сделать так, то нижерасположенные строки не пострадают, будут сдвигаться(ну и ActiveSheet здесь употреблять можно, но вызовет ненужные вычисления, лучше использовать зарезервированный объект Ме): [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set r = Intersect(Target, Range("Таблица1")) If Not r Is Nothing Then Application.EnableEvents = False Me.Unprotect "1" lr = [a1].CurrentRegion.Rows.Count ll = Me.ListObjects(1).Range.Rows.Count For i = 1 To 3 - (ll - lr) Me.ListObjects(1).ListRows.Add ll, True Next ' Me.ListObjects("Таблица1").Resize Range("a1:g" & lr + 3) Me.Protect "1" Application.EnableEvents = True End If End Sub
ActiveSheet.ListObjects("Таблица1").Resize Range("a1:g" & lr + 3)
Если сделать так, то нижерасположенные строки не пострадают, будут сдвигаться(ну и ActiveSheet здесь употреблять можно, но вызовет ненужные вычисления, лучше использовать зарезервированный объект Ме): [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Set r = Intersect(Target, Range("Таблица1")) If Not r Is Nothing Then Application.EnableEvents = False Me.Unprotect "1" lr = [a1].CurrentRegion.Rows.Count ll = Me.ListObjects(1).Range.Rows.Count For i = 1 To 3 - (ll - lr) Me.ListObjects(1).ListRows.Add ll, True Next ' Me.ListObjects("Таблица1").Resize Range("a1:g" & lr + 3) Me.Protect "1" Application.EnableEvents = True End If End Sub
Manyasha, вчера открыл "stroki-1" попробовал, все работало. Сегодня попытался внедрить макрос в реальный файл. Ничего не получилось. Более того перестал работать вчерашний файл (даже при повторной загрузке). KuklP, Ваш тоже пытался применить. Безуспешно. Ничего не понимаю
Manyasha, вчера открыл "stroki-1" попробовал, все работало. Сегодня попытался внедрить макрос в реальный файл. Ничего не получилось. Более того перестал работать вчерашний файл (даже при повторной загрузке). KuklP, Ваш тоже пытался применить. Безуспешно. Ничего не понимаю Leprotto
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица31")) Is Nothing Then Application.EnableEvents = False With Me.ListObjects("Таблица31") Me.Unprotect "1" For lr& = .ListRows.Count To 2 Step -1 n& = n& + 1 If Application.CountA(.ListRows(lr&).Range) > 3 Then Exit For Next For i& = 1 To 4 - n& .ListRows.Add lr + 1, True Next End With Me.Protect "1" Application.EnableEvents = True End If End Sub
[/vba]
Еще вариант: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица31")) Is Nothing Then Application.EnableEvents = False With Me.ListObjects("Таблица31") Me.Unprotect "1" For lr& = .ListRows.Count To 2 Step -1 n& = n& + 1 If Application.CountA(.ListRows(lr&).Range) > 3 Then Exit For Next For i& = 1 To 4 - n& .ListRows.Add lr + 1, True Next End With Me.Protect "1" Application.EnableEvents = True End If End Sub