Добрый вечер. Помогите пожалуйста решить проблему. На Листе 1 имеется умная таблица, на Листе 2 - сводная. На листах снизу этих таблиц имеются данные, которые должны сохраниться и опускаться вниз при расширении данных таблиц. Нашел где-то решение для 2 умных таблиц, расположенных друг над другом. Вроде внедрил для Листа 2, но для этого пришлось заводить еще одну (пустую) умную таблицу.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица2").Row If b - a = 3 Then Rows(a + 1).Insert Shift:=xlDown Rows(a * 2 + 2).Insert Shift:=xlDown End If End If End Sub
[/vba]
Но для Сводной (Лист 1) ничего не получается. Может быть есть другое решение?. Заранее спасибо
Добрый вечер. Помогите пожалуйста решить проблему. На Листе 1 имеется умная таблица, на Листе 2 - сводная. На листах снизу этих таблиц имеются данные, которые должны сохраниться и опускаться вниз при расширении данных таблиц. Нашел где-то решение для 2 умных таблиц, расположенных друг над другом. Вроде внедрил для Листа 2, но для этого пришлось заводить еще одну (пустую) умную таблицу.
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица2").Row If b - a = 3 Then Rows(a + 1).Insert Shift:=xlDown Rows(a * 2 + 2).Insert Shift:=xlDown End If End If End Sub
[/vba]
Но для Сводной (Лист 1) ничего не получается. Может быть есть другое решение?. Заранее спасибоVadimSh
но для этого пришлось заводить еще одну (пустую) умную таблицу
Можно и без дополнительной таблицы. Удалите её и вставьте следуйщий код вместо вашего кода: [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Таблица1") Dim tblHeader As Range: Set tblHeader = tbl.HeaderRowRange Dim tblRow As ListRow: Set tblRow = tbl.ListRows(tbl.ListRows.Count) Dim adRow As Long: adRow = tblHeader.Row + tblRow.Index adRow = adRow + 2
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then Rows(adRow).Insert Shift:=xlDown End If
но для этого пришлось заводить еще одну (пустую) умную таблицу
Можно и без дополнительной таблицы. Удалите её и вставьте следуйщий код вместо вашего кода: [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Таблица1") Dim tblHeader As Range: Set tblHeader = tbl.HeaderRowRange Dim tblRow As ListRow: Set tblRow = tbl.ListRows(tbl.ListRows.Count) Dim adRow As Long: adRow = tblHeader.Row + tblRow.Index adRow = adRow + 2
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then Rows(adRow).Insert Shift:=xlDown End If
Спасибо за помощь. С кодом MikeVol работает на листе с умной таблицей. Проблема возникла со сводной таблицей. В отличии от умных таблиц которые могут увеличиваются на 1 строку сводная таблица при обновлении может увеличиться на любое количество строк. Например сводная таблица занимает сроки с 1 по 10. В 12 строке и ниже имеются другие Данные, которые не относятся к сводной таблице. После добавления данных в умной таблице и обновлении сводной она стала занимать строки с 1 по 15 (добавились 5 строк), при этом затерло все что было с 12 по 15 строку. Как реализовать так что-бы при обновлении сводной таблицы нужные мне строки смещались вниз на то количество строк, что добавились в сводную таблицу и данные не терялись?
Спасибо за помощь. С кодом MikeVol работает на листе с умной таблицей. Проблема возникла со сводной таблицей. В отличии от умных таблиц которые могут увеличиваются на 1 строку сводная таблица при обновлении может увеличиться на любое количество строк. Например сводная таблица занимает сроки с 1 по 10. В 12 строке и ниже имеются другие Данные, которые не относятся к сводной таблице. После добавления данных в умной таблице и обновлении сводной она стала занимать строки с 1 по 15 (добавились 5 строк), при этом затерло все что было с 12 по 15 строку. Как реализовать так что-бы при обновлении сводной таблицы нужные мне строки смещались вниз на то количество строк, что добавились в сводную таблицу и данные не терялись?VadimSh
VadimSh, Доброго времени суток. К сожелению мной было найдена ошибка в моём коде которая добовляло строки ниже независимо от добавление новой строки в Умную таблицу. При любом изминение в этой Умной таблице приводило к добавлению строк ниже данной таблицы. Вот изменённый код который отслеживает изминение только во втором столбце (Наименование ) а не во всей таблице: [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Таблица1") Dim tblHeader As Range: Set tblHeader = tbl.HeaderRowRange Dim tblCol As ListColumn: Set tblCol = tbl.ListColumns("Наименование ")
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then
If Not Intersect(Target, tblCol.DataBodyRange) Is Nothing Then Dim adRow As Long: adRow = tblHeader.Row + tbl.ListRows(tbl.ListRows.Count).Index + 2 Rows(adRow).Insert Shift:=xlDown End If
End If
End Sub
[/vba]
VadimSh, Доброго времени суток. К сожелению мной было найдена ошибка в моём коде которая добовляло строки ниже независимо от добавление новой строки в Умную таблицу. При любом изминение в этой Умной таблице приводило к добавлению строк ниже данной таблицы. Вот изменённый код который отслеживает изминение только во втором столбце (Наименование ) а не во всей таблице: [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Таблица1") Dim tblHeader As Range: Set tblHeader = tbl.HeaderRowRange Dim tblCol As ListColumn: Set tblCol = tbl.ListColumns("Наименование ")
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then
If Not Intersect(Target, tblCol.DataBodyRange) Is Nothing Then Dim adRow As Long: adRow = tblHeader.Row + tbl.ListRows(tbl.ListRows.Count).Index + 2 Rows(adRow).Insert Shift:=xlDown End If
MikeVol, спасибо еще раз. Я и не обратил внимание на ошибку в Вашем коде. Поправил и обратил внимание, что и 2 код тоже работает неверно. Добавление строк ниже таблицы должно происходить только при добавлении Новой строки в умную таблицу (увеличении количества строк). Данные в таблице могу меняться сколько угодно, в том числе и во 2 столбе
MikeVol, спасибо еще раз. Я и не обратил внимание на ошибку в Вашем коде. Поправил и обратил внимание, что и 2 код тоже работает неверно. Добавление строк ниже таблицы должно происходить только при добавлении Новой строки в умную таблицу (увеличении количества строк). Данные в таблице могу меняться сколько угодно, в том числе и во 2 столбеVadimSh
MikeVol, еще раз проверил Ваш код. Он добавляет пустую строку при любом изменении в Наименовании (В). А нужно чтобы при добавлении любых данных (не только Наименование) в первую пустую строку умной таблицы. Файл прикладываю
MikeVol, еще раз проверил Ваш код. Он добавляет пустую строку при любом изменении в Наименовании (В). А нужно чтобы при добавлении любых данных (не только Наименование) в первую пустую строку умной таблицы. Файл прикладываюVadimSh
MikeVol, спасибо за ваши ответы. Я правильно понял в вашем коде? В первом варианте вашего кода строка добавлялась при: 1. Изменении/правке любой имеющейся ячейки в умной таблице (не правильно) 2. При вводе любых данных в новую строку умной таблицы (правильно) Во втором варианте вашего кода строка добавлялась при: 1. Изменении/правке любой имеющейся ячейки в столбце "Наименование" (не правильно) 2. При вводе "Наименования" в новую строку умной таблицы (не правильно). Должно быть так. Строка вставляется только при одном условии: Ввод любых данных в новую строку умной таблицы (таблица расширяется).
Если это нельзя сделать, то просто придется постоянно удалять лишние создаваемые строки.
MikeVol, спасибо за ваши ответы. Я правильно понял в вашем коде? В первом варианте вашего кода строка добавлялась при: 1. Изменении/правке любой имеющейся ячейки в умной таблице (не правильно) 2. При вводе любых данных в новую строку умной таблицы (правильно) Во втором варианте вашего кода строка добавлялась при: 1. Изменении/правке любой имеющейся ячейки в столбце "Наименование" (не правильно) 2. При вводе "Наименования" в новую строку умной таблицы (не правильно). Должно быть так. Строка вставляется только при одном условии: Ввод любых данных в новую строку умной таблицы (таблица расширяется).
Если это нельзя сделать, то просто придется постоянно удалять лишние создаваемые строки.VadimSh
Тут мне кажется лучше отредактировать код с 2-мя умными таблицами. Моих знаний не хватает, поэтому прошу помощи. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица2").Row If b - a = 3 Then Rows(a + 1).Insert Shift:=xlDown End If End If End Sub
[/vba] И как это реализовать со сводной таблицей?
Тут мне кажется лучше отредактировать код с 2-мя умными таблицами. Моих знаний не хватает, поэтому прошу помощи. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица2").Row If b - a = 3 Then Rows(a + 1).Insert Shift:=xlDown End If End If End Sub
[/vba] И как это реализовать со сводной таблицей?VadimSh
Сообщение отредактировал VadimSh - Четверг, 12.10.2023, 12:27
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица1").Row c = Range("Таблица1").Rows.Count If b + c - 1 = a Then Rows(a + 1).Insert Rows(a + 1).Clear End If End If End Sub
[/vba] на счет сводной я бы наверное обратился к исходным данным и определил куда сдвинуть строки
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица1").Row c = Range("Таблица1").Rows.Count If b + c - 1 = a Then Rows(a + 1).Insert Rows(a + 1).Clear End If End If End Sub
[/vba] на счет сводной я бы наверное обратился к исходным данным и определил куда сдвинуть строкиNic70y
Nic70y, Приветсвую вас. Теперь пробуйте добавить запись, скажем в 16-ю строку. И теперь в той-же строке отредактируйте запись. Как, строка ещё одна добавилась? Но она не должна добавляться. VadimSh необходимо держать разрыв (6 строк) между умной таблицей (Таблица1) и теми данными что идут уже под ней.
Nic70y, Приветсвую вас. Теперь пробуйте добавить запись, скажем в 16-ю строку. И теперь в той-же строке отредактируйте запись. Как, строка ещё одна добавилась? Но она не должна добавляться. VadimSh необходимо держать разрыв (6 строк) между умной таблицей (Таблица1) и теми данными что идут уже под ней.MikeVol
Ученик.
Сообщение отредактировал MikeVol - Четверг, 12.10.2023, 19:07
MikeVol, здравствуйте. есть такое, недотестил, для данного случая можно добавить проверку [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица1").Row c = Range("Таблица1").Rows.Count d = Target.Offset(1, 0) If b + c - 1 = a And d <> "" Then Rows(a + 1).Insert Rows(a + 1).Clear End If End If End Sub
[/vba]
MikeVol, здравствуйте. есть такое, недотестил, для данного случая можно добавить проверку [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица1").Row c = Range("Таблица1").Rows.Count d = Target.Offset(1, 0) If b + c - 1 = a And d <> "" Then Rows(a + 1).Insert Rows(a + 1).Clear End If End If End Sub
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица1").Row c = Range("Таблица1").Rows.Count d = Target.Offset(1, 0) If b + c - 1 = a And d <> "" Then Rows(a + 1).Insert Rows(a + 1).Clear End If End If End Sub
Nic70y спасибо за помощь. Есть только одна проблема с этим кодом: в умной таблице если вырезать строку и попытаться ее вставить ваш код выдает ошибку (без кода работает)
Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Range("Таблица1")) Is Nothing Then a = Target.Row b = Range("Таблица1").Row c = Range("Таблица1").Rows.Count d = Target.Offset(1, 0) If b + c - 1 = a And d <> "" Then Rows(a + 1).Insert Rows(a + 1).Clear End If End If End Sub
Nic70y спасибо за помощь. Есть только одна проблема с этим кодом: в умной таблице если вырезать строку и попытаться ее вставить ваш код выдает ошибку (без кода работает)VadimSh
VadimSh, Вопрос к вам. А на Листе2 (Таблица1) в колонке "Наименование " так и будут такие цифры идти или всё же будут какие-то уникальные наименования?
VadimSh, Вопрос к вам. А на Листе2 (Таблица1) в колонке "Наименование " так и будут такие цифры идти или всё же будут какие-то уникальные наименования?MikeVol
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
