anisimovaleksandr32, Можно ещё такой код применить для вашего случая так как у вас на обеих страницах Умные Таблицы. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim tbl2 As ListObject: Set tbl2 = ThisWorkbook.Worksheets("ЗАКЛЮЧЕНИЕ").ListObjects("Заключение") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then Dim tbl1RowCount As Long: tbl1RowCount = tbl.ListRows.Count Dim tbl2RowCount As Long: tbl2RowCount = tbl2.ListRows.Count
If tbl2RowCount <> tbl1RowCount Then
If tbl2RowCount < tbl1RowCount Then tbl2.ListRows.Add tbl1RowCount - tbl2RowCount Else tbl2.ListRows(tbl1RowCount + 1).Delete End If
End If
tbl2.DataBodyRange.Resize(tbl1RowCount, tbl2.ListColumns.Count).Value = tbl.DataBodyRange.Value tbl2.ListColumns("Наименьшее значение для отбраковки").DataBodyRange.FormulaR1C1 = "=INDEX(В35!R16C3:R100C3, ROW(), COLUMN())" End If
Application.ScreenUpdating = True End Sub
[/vba]
anisimovaleksandr32, Можно ещё такой код применить для вашего случая так как у вас на обеих страницах Умные Таблицы. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim tbl2 As ListObject: Set tbl2 = ThisWorkbook.Worksheets("ЗАКЛЮЧЕНИЕ").ListObjects("Заключение") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then Dim tbl1RowCount As Long: tbl1RowCount = tbl.ListRows.Count Dim tbl2RowCount As Long: tbl2RowCount = tbl2.ListRows.Count
If tbl2RowCount <> tbl1RowCount Then
If tbl2RowCount < tbl1RowCount Then tbl2.ListRows.Add tbl1RowCount - tbl2RowCount Else tbl2.ListRows(tbl1RowCount + 1).Delete End If
End If
tbl2.DataBodyRange.Resize(tbl1RowCount, tbl2.ListColumns.Count).Value = tbl.DataBodyRange.Value tbl2.ListColumns("Наименьшее значение для отбраковки").DataBodyRange.FormulaR1C1 = "=INDEX(В35!R16C3:R100C3, ROW(), COLUMN())" End If
anisimovaleksandr32, это ваша формула что была в последнем файле примере от вас. Подумал что она вам нужна, если нет то закоментируйте данную строку или полностью её удалите из кода.
anisimovaleksandr32, это ваша формула что была в последнем файле примере от вас. Подумал что она вам нужна, если нет то закоментируйте данную строку или полностью её удалите из кода.MikeVol
Добрый день "Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист" На листе "Заключение" добавь код который в конце сообщения и не парься. Отформатируй таблицу как хочешь только форматируй "таблицу" а не диапазоны - при обновлении форматирование остается (в том числе условное). "Нашел при этом одну тему хорошую My WebPage в которой было решение через создание подключения." Можно но так как это "подключение"- форматы заголовков могут слетать (почему - не разобрался , скорее всего из-за изменения типа данных в столбце). "А потом подумал.." Это зря - пусть лошадь думает - у нее голова большая )) нам работать нужно код: [vba]
Код
Option Explicit Private Sub Worksheet_Activate() Dim iArr As Variant With ActiveSheet If Not .ListObjects(1).DataBodyRange Is Nothing Then .ListObjects(1).DataBodyRange.Delete iArr = ActiveWorkbook.Sheets("В35").ListObjects(1).DataBodyRange Call ArToLo(iArr, .ListObjects(1)) End With End Sub Private Sub ArToLo(ByRef mArr As Variant, ByVal mLO As ListObject) ' mLO.AutoFilter.ShowAllData mLO.Parent.Cells(mLO.Range.Row + mLO.ListRows.Count + 1, mLO.Range.Column).Resize(UBound(mArr, 1), UBound(mArr, 2)) = mArr End Sub
[/vba] -- надеюсь помог
Добрый день "Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист" На листе "Заключение" добавь код который в конце сообщения и не парься. Отформатируй таблицу как хочешь только форматируй "таблицу" а не диапазоны - при обновлении форматирование остается (в том числе условное). "Нашел при этом одну тему хорошую My WebPage в которой было решение через создание подключения." Можно но так как это "подключение"- форматы заголовков могут слетать (почему - не разобрался , скорее всего из-за изменения типа данных в столбце). "А потом подумал.." Это зря - пусть лошадь думает - у нее голова большая )) нам работать нужно код: [vba]
Код
Option Explicit Private Sub Worksheet_Activate() Dim iArr As Variant With ActiveSheet If Not .ListObjects(1).DataBodyRange Is Nothing Then .ListObjects(1).DataBodyRange.Delete iArr = ActiveWorkbook.Sheets("В35").ListObjects(1).DataBodyRange Call ArToLo(iArr, .ListObjects(1)) End With End Sub Private Sub ArToLo(ByRef mArr As Variant, ByVal mLO As ListObject) ' mLO.AutoFilter.ShowAllData mLO.Parent.Cells(mLO.Range.Row + mLO.ListRows.Count + 1, mLO.Range.Column).Resize(UBound(mArr, 1), UBound(mArr, 2)) = mArr End Sub
leseal, И как там, ничего не удалилось на листе "ЗАКЛЮЧЕНИЕ" и ничего не сметилось, все данные которые должны быть под таблицей остались на прежнем месте?
leseal, И как там, ничего не удалилось на листе "ЗАКЛЮЧЕНИЕ" и ничего не сметилось, все данные которые должны быть под таблицей остались на прежнем месте?MikeVol
MikeVol, я не преследовал задачи сохранить Вашу форму для печати, а решал ту задачу , что Вы указали в сообщении Цитата : "Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист" Или Вы подразумеваете что отвечая на вопрос нужно еще подогнать области печати , переписать имеющиеся макросы, исправить ошибки в формате примечаний итд итп? Тогда в сообщении указывайте ЭТО всё !
MikeVol, я не преследовал задачи сохранить Вашу форму для печати, а решал ту задачу , что Вы указали в сообщении Цитата : "Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист" Или Вы подразумеваете что отвечая на вопрос нужно еще подогнать области печати , переписать имеющиеся макросы, исправить ошибки в формате примечаний итд итп? Тогда в сообщении указывайте ЭТО всё !leseal
Что бы взбодриться достаточно стукнуть голой ногой ножку кровати
leseal, Я рад что вы пытаетесь кому-то тут помочь, но. Добро Пожаловать на данный форум! 1) Читайте всегда Внимательно все посты, сосбенно кто сам автор темы. 2) В вашем коде в строке: [vba]
Код
If Not .ListObjects(1).DataBodyRange Is Nothing Then .ListObjects(1).DataBodyRange.Delete
[/vba] вы полностью удаляете строки ListObjects(1) тем самым вы смещаете весь диапазон Листа что не требовалось (читайте описания от ТС) 3) Причём данная строка в данном случае: [vba]
Код
mLO.AutoFilter.ShowAllData
[/vba] если на листах нигде не применяются фильтра? 4) Снова Повторюсь: Читайте всегда Внимательно все посты чтоб не оказаться в неловком положение! Теперь смотрим скриншоты ниже.
И ещё, пробуйте ещё пару раз перейти с листа на лист, как там с данными?
leseal, Я рад что вы пытаетесь кому-то тут помочь, но. Добро Пожаловать на данный форум! 1) Читайте всегда Внимательно все посты, сосбенно кто сам автор темы. 2) В вашем коде в строке: [vba]
Код
If Not .ListObjects(1).DataBodyRange Is Nothing Then .ListObjects(1).DataBodyRange.Delete
[/vba] вы полностью удаляете строки ListObjects(1) тем самым вы смещаете весь диапазон Листа что не требовалось (читайте описания от ТС) 3) Причём данная строка в данном случае: [vba]
Код
mLO.AutoFilter.ShowAllData
[/vba] если на листах нигде не применяются фильтра? 4) Снова Повторюсь: Читайте всегда Внимательно все посты чтоб не оказаться в неловком положение! Теперь смотрим скриншоты ниже.
И ещё, пробуйте ещё пару раз перейти с листа на лист, как там с данными?MikeVol
Расположите листы по порядку не вертикально, а горизонтально - тогда ограничением будет только размер листа. Если же листа не хватит для отображения таблицы (строк больше чем помещается на листе) , как минимум, Word Вам в помощь вставляйте все объектами и не будет вопросов - имена правильные у документов будут , и по папочкам разложите, и авторство закрепите в документе .... Другой вариант : всегда "формируйте" лист отчета заново, собирая его в нужной последовательности (картинки можно спокойно вписать в размеры ячейки и вставлять их куда угодно)
anisimovaleksandr32,
Расположите листы по порядку не вертикально, а горизонтально - тогда ограничением будет только размер листа. Если же листа не хватит для отображения таблицы (строк больше чем помещается на листе) , как минимум, Word Вам в помощь вставляйте все объектами и не будет вопросов - имена правильные у документов будут , и по папочкам разложите, и авторство закрепите в документе .... Другой вариант : всегда "формируйте" лист отчета заново, собирая его в нужной последовательности (картинки можно спокойно вписать в размеры ячейки и вставлять их куда угодно)leseal
Что бы взбодриться достаточно стукнуть голой ногой ножку кровати
MikeVol, 1 - перечитал 2 - данные таблицы удаляю для того что бы не устраивать "танцы с бубнами" вокруг количества строк/столбцов - если пользователь добавит в этой таблице еще столбец с формулами нужно чистить остатки при сокращении количества строк итп. сам сталкивался с этим неоднократно поэтому такой вариант не рассматриваю в своих мыслях 3 - использовал свою стандартную подпрограмму - не заметил что они выключены (хотя зачем ? ведь на печать они не выводятся) 4 - повторяюсь- решал задачу быстро/просто/гарантировано повторить данные с первой таблицы , которая является ведущей, зачем кодом vba (не самый скудный язык) решать вопрос непродуманного (без обид автору) оформления - не знаю Данные на листе есть ? оформление дело техники - в конце концов есть "Private Sub Workbook_BeforePrint"
MikeVol, 1 - перечитал 2 - данные таблицы удаляю для того что бы не устраивать "танцы с бубнами" вокруг количества строк/столбцов - если пользователь добавит в этой таблице еще столбец с формулами нужно чистить остатки при сокращении количества строк итп. сам сталкивался с этим неоднократно поэтому такой вариант не рассматриваю в своих мыслях 3 - использовал свою стандартную подпрограмму - не заметил что они выключены (хотя зачем ? ведь на печать они не выводятся) 4 - повторяюсь- решал задачу быстро/просто/гарантировано повторить данные с первой таблицы , которая является ведущей, зачем кодом vba (не самый скудный язык) решать вопрос непродуманного (без обид автору) оформления - не знаю Данные на листе есть ? оформление дело техники - в конце концов есть "Private Sub Workbook_BeforePrint"leseal
Что бы взбодриться достаточно стукнуть голой ногой ножку кровати
anisimovaleksandr32, Как у Жванецкого "Почем стоит похоронить? - "10 рублей" - "А если без покойника ?" - "7рублей - но это унизительно для всего коллектива" [vba]
Код
Option Explicit Private Sub Worksheet_Activate() Application.ScreenUpdating = False Dim iArr As Variant Dim iRow As Long iArr = ActiveWorkbook.Sheets("Â35").ListObjects(1).DataBodyRange With ActiveSheet If .ListObjects(1).Range.Row = 50 And UBound(iArr, 1) <= 86 - 51 Then 'proverka polozeniya tab i strok tab If Not .ListObjects(1).DataBodyRange Is Nothing Then For iRow = 1 To ListObjects(1).Range.Rows.Count - 2 .Rows(86).Insert 'stroka pered oformleniem Next iRow .ListObjects(1).DataBodyRange.Delete End If Else MsgBox ("BEDA !") Application.ScreenUpdating = True Exit Sub End If ' Call ArToLo(iArr, .ListObjects(1)) End With Application.ScreenUpdating = True End Sub Private Sub ArToLo(ByRef mArr As Variant, ByVal mLO As ListObject) ' 'mLO.AutoFilter.ShowAllData mLO.Parent.Cells(mLO.Range.Row + mLO.ListRows.Count + 1, mLO.Range.Column).Resize(UBound(mArr, 1), UBound(mArr, 2)) = mArr End Sub
[/vba] Но самому стыдно за такую "работу" )) особливо за удаление строк....
anisimovaleksandr32, Как у Жванецкого "Почем стоит похоронить? - "10 рублей" - "А если без покойника ?" - "7рублей - но это унизительно для всего коллектива" [vba]
Код
Option Explicit Private Sub Worksheet_Activate() Application.ScreenUpdating = False Dim iArr As Variant Dim iRow As Long iArr = ActiveWorkbook.Sheets("Â35").ListObjects(1).DataBodyRange With ActiveSheet If .ListObjects(1).Range.Row = 50 And UBound(iArr, 1) <= 86 - 51 Then 'proverka polozeniya tab i strok tab If Not .ListObjects(1).DataBodyRange Is Nothing Then For iRow = 1 To ListObjects(1).Range.Rows.Count - 2 .Rows(86).Insert 'stroka pered oformleniem Next iRow .ListObjects(1).DataBodyRange.Delete End If Else MsgBox ("BEDA !") Application.ScreenUpdating = True Exit Sub End If ' Call ArToLo(iArr, .ListObjects(1)) End With Application.ScreenUpdating = True End Sub Private Sub ArToLo(ByRef mArr As Variant, ByVal mLO As ListObject) ' 'mLO.AutoFilter.ShowAllData mLO.Parent.Cells(mLO.Range.Row + mLO.ListRows.Count + 1, mLO.Range.Column).Resize(UBound(mArr, 1), UBound(mArr, 2)) = mArr End Sub
[/vba] Но самому стыдно за такую "работу" )) особливо за удаление строк....leseal
Что бы взбодриться достаточно стукнуть голой ногой ножку кровати