Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Дублирование основной таблицы на другой лист (только знач) - Страница 2 - Мир MS Excel

Старая форма входа
  • Страница 2 из 2
  • «
  • 1
  • 2
Модератор форума: китин, _Boroda_  
Дублирование основной таблицы на другой лист (только знач)
MikeVol Дата: Понедельник, 23.10.2023, 15:16 | Сообщение № 21
Группа: Проверенные
Ранг: Обитатель
Сообщений: 318
Репутация: 64 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
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]


Ученик.

Сообщение отредактировал MikeVol - Понедельник, 23.10.2023, 15:19
 
Ответить
Сообщение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]

Автор - MikeVol
Дата добавления - 23.10.2023 в 15:16
anisimovaleksandr32 Дата: Понедельник, 23.10.2023, 15:29 | Сообщение № 22
Группа: Пользователи
Ранг: Участник
Сообщений: 86
Репутация: 4 ±
Замечаний: 20% ±

MikeVol, :o ОГОНЬ hands
С П А С И Б О ВАМ О Г Р О М Н Е Й Ш Е Е!!!
Лишь тут в таблице скопированной нули
[vba]
Код
tbl2.ListColumns("Наименьшее значение для отбраковки").DataBodyRange.FormulaR1C1 = "=INDEX(В35!R16C3:R100C3, ROW(), COLUMN())"
[/vba]


Сообщение отредактировал anisimovaleksandr32 - Понедельник, 23.10.2023, 15:30
 
Ответить
СообщениеMikeVol, :o ОГОНЬ hands
С П А С И Б О ВАМ О Г Р О М Н Е Й Ш Е Е!!!
Лишь тут в таблице скопированной нули
[vba]
Код
tbl2.ListColumns("Наименьшее значение для отбраковки").DataBodyRange.FormulaR1C1 = "=INDEX(В35!R16C3:R100C3, ROW(), COLUMN())"
[/vba]

Автор - anisimovaleksandr32
Дата добавления - 23.10.2023 в 15:29
MikeVol Дата: Понедельник, 23.10.2023, 16:03 | Сообщение № 23
Группа: Проверенные
Ранг: Обитатель
Сообщений: 318
Репутация: 64 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
anisimovaleksandr32, это ваша формула что была в последнем файле примере от вас. Подумал что она вам нужна, если нет то закоментируйте данную строку или полностью её удалите из кода.


Ученик.
 
Ответить
Сообщениеanisimovaleksandr32, это ваша формула что была в последнем файле примере от вас. Подумал что она вам нужна, если нет то закоментируйте данную строку или полностью её удалите из кода.

Автор - MikeVol
Дата добавления - 23.10.2023 в 16:03
leseal Дата: Среда, 25.10.2023, 16:37 | Сообщение № 24
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: -2 ±
Замечаний: 0% ±

16
Добрый день
"Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист"
На листе "Заключение" добавь код который в конце сообщения и не парься. Отформатируй таблицу как хочешь только форматируй "таблицу" а не диапазоны - при обновлении форматирование остается (в том числе условное).
"Нашел при этом одну тему хорошую 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]
--
надеюсь помог


Что бы взбодриться достаточно стукнуть голой ногой ножку кровати

Сообщение отредактировал Serge_007 - Среда, 25.10.2023, 19:02
 
Ответить
СообщениеДобрый день
"Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист"
На листе "Заключение" добавь код который в конце сообщения и не парься. Отформатируй таблицу как хочешь только форматируй "таблицу" а не диапазоны - при обновлении форматирование остается (в том числе условное).
"Нашел при этом одну тему хорошую 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]
--
надеюсь помог

Автор - leseal
Дата добавления - 25.10.2023 в 16:37
MikeVol Дата: Среда, 25.10.2023, 16:50 | Сообщение № 25
Группа: Проверенные
Ранг: Обитатель
Сообщений: 318
Репутация: 64 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
leseal, Доброго времени суток. А вы тестировали ваш код перед тем как опубликовать его сюда?


Ученик.
 
Ответить
Сообщениеleseal, Доброго времени суток. А вы тестировали ваш код перед тем как опубликовать его сюда?

Автор - MikeVol
Дата добавления - 25.10.2023 в 16:50
leseal Дата: Среда, 25.10.2023, 16:51 | Сообщение № 26
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: -2 ±
Замечаний: 0% ±

16
leseal, Да


Что бы взбодриться достаточно стукнуть голой ногой ножку кровати
 
Ответить
Сообщениеleseal, Да

Автор - leseal
Дата добавления - 25.10.2023 в 16:51
MikeVol Дата: Среда, 25.10.2023, 16:54 | Сообщение № 27
Группа: Проверенные
Ранг: Обитатель
Сообщений: 318
Репутация: 64 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
leseal, И как там, ничего не удалилось на листе "ЗАКЛЮЧЕНИЕ" и ничего не сметилось, все данные которые должны быть под таблицей остались на прежнем месте?


Ученик.
 
Ответить
Сообщениеleseal, И как там, ничего не удалилось на листе "ЗАКЛЮЧЕНИЕ" и ничего не сметилось, все данные которые должны быть под таблицей остались на прежнем месте?

Автор - MikeVol
Дата добавления - 25.10.2023 в 16:54
leseal Дата: Среда, 25.10.2023, 16:54 | Сообщение № 28
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: -2 ±
Замечаний: 0% ±

16
MikeVol, Да . что не так ?


Что бы взбодриться достаточно стукнуть голой ногой ножку кровати
 
Ответить
СообщениеMikeVol, Да . что не так ?

Автор - leseal
Дата добавления - 25.10.2023 в 16:54
MikeVol Дата: Среда, 25.10.2023, 16:56 | Сообщение № 29
Группа: Проверенные
Ранг: Обитатель
Сообщений: 318
Репутация: 64 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
leseal, Приложите файл пример с вашим кодом который вы предложили. Посмотрим что да как там с данными на листе.


Ученик.
 
Ответить
Сообщениеleseal, Приложите файл пример с вашим кодом который вы предложили. Посмотрим что да как там с данными на листе.

Автор - MikeVol
Дата добавления - 25.10.2023 в 16:56
leseal Дата: Среда, 25.10.2023, 17:04 | Сообщение № 30
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: -2 ±
Замечаний: 0% ±

16
MikeVol, я не преследовал задачи сохранить Вашу форму для печати, а решал ту задачу , что Вы указали в сообщении Цитата : "Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист"
Или Вы подразумеваете что отвечая на вопрос нужно еще подогнать области печати , переписать имеющиеся макросы, исправить ошибки в формате примечаний итд итп?
Тогда в сообщении указывайте ЭТО всё !


Что бы взбодриться достаточно стукнуть голой ногой ножку кровати
 
Ответить
СообщениеMikeVol, я не преследовал задачи сохранить Вашу форму для печати, а решал ту задачу , что Вы указали в сообщении Цитата : "Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист"
Или Вы подразумеваете что отвечая на вопрос нужно еще подогнать области печати , переписать имеющиеся макросы, исправить ошибки в формате примечаний итд итп?
Тогда в сообщении указывайте ЭТО всё !

Автор - leseal
Дата добавления - 25.10.2023 в 17:04
MikeVol Дата: Среда, 25.10.2023, 17:15 | Сообщение № 31
Группа: Проверенные
Ранг: Обитатель
Сообщений: 318
Репутация: 64 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
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) Снова Повторюсь: Читайте всегда Внимательно все посты чтоб не оказаться в неловком положение!
Теперь смотрим скриншоты ниже.

И ещё, пробуйте ещё пару раз перейти с листа на лист, как там с данными?
К сообщению приложен файл: 6456497.png (294.7 Kb) · 1952471.png (56.7 Kb)


Ученик.

Сообщение отредактировал MikeVol - Среда, 25.10.2023, 17:24
 
Ответить
Сообщение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
Дата добавления - 25.10.2023 в 17:15
leseal Дата: Среда, 25.10.2023, 17:48 | Сообщение № 32
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: -2 ±
Замечаний: 0% ±

16
anisimovaleksandr32,

Расположите листы по порядку не вертикально, а горизонтально - тогда ограничением будет только размер листа. Если же листа не хватит для отображения таблицы (строк больше чем помещается на листе) , как минимум, Word Вам в помощь вставляйте все объектами и не будет вопросов - имена правильные у документов будут , и по папочкам разложите, и авторство закрепите в документе ....
Другой вариант : всегда "формируйте" лист отчета заново, собирая его в нужной последовательности (картинки можно спокойно вписать в размеры ячейки и вставлять их куда угодно)


Что бы взбодриться достаточно стукнуть голой ногой ножку кровати
 
Ответить
Сообщениеanisimovaleksandr32,

Расположите листы по порядку не вертикально, а горизонтально - тогда ограничением будет только размер листа. Если же листа не хватит для отображения таблицы (строк больше чем помещается на листе) , как минимум, Word Вам в помощь вставляйте все объектами и не будет вопросов - имена правильные у документов будут , и по папочкам разложите, и авторство закрепите в документе ....
Другой вариант : всегда "формируйте" лист отчета заново, собирая его в нужной последовательности (картинки можно спокойно вписать в размеры ячейки и вставлять их куда угодно)

Автор - leseal
Дата добавления - 25.10.2023 в 17:48
MikeVol Дата: Среда, 25.10.2023, 17:51 | Сообщение № 33
Группа: Проверенные
Ранг: Обитатель
Сообщений: 318
Репутация: 64 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
leseal, А как же быть с
Тогда в сообщении указывайте ЭТО всё !
???


Ученик.
 
Ответить
Сообщениеleseal, А как же быть с
Тогда в сообщении указывайте ЭТО всё !
???

Автор - MikeVol
Дата добавления - 25.10.2023 в 17:51
leseal Дата: Среда, 25.10.2023, 18:08 | Сообщение № 34
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: -2 ±
Замечаний: 0% ±

16
MikeVol,
1 - перечитал
2 - данные таблицы удаляю для того что бы не устраивать "танцы с бубнами" вокруг количества строк/столбцов - если пользователь добавит в этой таблице еще столбец с формулами нужно чистить остатки при сокращении количества строк итп. сам сталкивался с этим неоднократно поэтому такой вариант не рассматриваю в своих мыслях
3 - использовал свою стандартную подпрограмму - не заметил что они выключены (хотя зачем ? ведь на печать они не выводятся)
4 - повторяюсь- решал задачу быстро/просто/гарантировано повторить данные с первой таблицы , которая является ведущей, зачем кодом vba (не самый скудный язык) решать вопрос непродуманного (без обид автору) оформления - не знаю
Данные на листе есть ? оформление дело техники - в конце концов есть "Private Sub Workbook_BeforePrint"


Что бы взбодриться достаточно стукнуть голой ногой ножку кровати
 
Ответить
СообщениеMikeVol,
1 - перечитал
2 - данные таблицы удаляю для того что бы не устраивать "танцы с бубнами" вокруг количества строк/столбцов - если пользователь добавит в этой таблице еще столбец с формулами нужно чистить остатки при сокращении количества строк итп. сам сталкивался с этим неоднократно поэтому такой вариант не рассматриваю в своих мыслях
3 - использовал свою стандартную подпрограмму - не заметил что они выключены (хотя зачем ? ведь на печать они не выводятся)
4 - повторяюсь- решал задачу быстро/просто/гарантировано повторить данные с первой таблицы , которая является ведущей, зачем кодом vba (не самый скудный язык) решать вопрос непродуманного (без обид автору) оформления - не знаю
Данные на листе есть ? оформление дело техники - в конце концов есть "Private Sub Workbook_BeforePrint"

Автор - leseal
Дата добавления - 25.10.2023 в 18:08
MikeVol Дата: Среда, 25.10.2023, 18:44 | Сообщение № 35
Группа: Проверенные
Ранг: Обитатель
Сообщений: 318
Репутация: 64 ±
Замечаний: 0% ±

Excel LTSC 2021 EN
leseal,
не заметил что они выключены (хотя зачем ? ведь на печать они не выводятся)
и что, даже никакой ошибки небыло вовремя работы вашего кода (как вот эта ошибка что на скриншотах ниже)?

данные таблицы удаляю для того что бы не устраивать "танцы с бубнами"
По вашему можно удалить/сместить строки это норм (как ТС просил в своих постах)?
Упс, забыл прикрепить скриншоты.
К сообщению приложен файл: 4241672.png (76.3 Kb) · 1036130.png (55.7 Kb)


Ученик.

Сообщение отредактировал MikeVol - Среда, 25.10.2023, 18:45
 
Ответить
Сообщениеleseal,
не заметил что они выключены (хотя зачем ? ведь на печать они не выводятся)
и что, даже никакой ошибки небыло вовремя работы вашего кода (как вот эта ошибка что на скриншотах ниже)?

данные таблицы удаляю для того что бы не устраивать "танцы с бубнами"
По вашему можно удалить/сместить строки это норм (как ТС просил в своих постах)?
Упс, забыл прикрепить скриншоты.

Автор - MikeVol
Дата добавления - 25.10.2023 в 18:44
leseal Дата: Пятница, 27.10.2023, 11:56 | Сообщение № 36
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: -2 ±
Замечаний: 0% ±

16
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
Дата добавления - 27.10.2023 в 11:56
  • Страница 2 из 2
  • «
  • 1
  • 2
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!