Добрый день всем, многоуважаемые форумчане. прошу вас подсказать/помочь: (файл прикладываю аналог не рабочий) Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист Произвел запись макроса:
После чего решил его прописать на основном листе (чтоб при каждом изменении на листе - происходило срабатывание данного макроса)
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) 'любые изменения на листе 'Больше не обновляем страницы после каждого действия Application.ScreenUpdating = False 'Отключаем события Application.EnableEvents = False With Range("Расчет[#All]").Select Selection.Copy Sheets("Лист2").Select Range("A26").Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("N14").Select 'Больше не обновляем страницы после каждого действия Application.ScreenUpdating = True 'Отключаем события Application.EnableEvents = True End With
End Sub
[/vba]
Но почему то теперь ругается.
Так еще и с возникнувшей проблемой - не могу посмотреть а если я удалю строки из таблицы или добавлю строки в таблицу (((( как быть. Нашел при этом одну тему хорошую My WebPage в которой было решение через создание подключения. В начале у меня все получилось (пришлось создать новый лист - туда вставить таблицу) но потом после наполнения информации на данный лист таблица начала сама изменять порядок столбцов (((( А потом подумал - а вдруг будет установлен офис старый тогда он и вовсе не обновит связи ((((
Как быть!? Подскажите пожалуйста
Добрый день всем, многоуважаемые форумчане. прошу вас подсказать/помочь: (файл прикладываю аналог не рабочий) Имеется таблица с данными "основная" в которой происходит расчеты. Данную таблицу нужно скопировать/продублировать на второй лист Произвел запись макроса:
После чего решил его прописать на основном листе (чтоб при каждом изменении на листе - происходило срабатывание данного макроса)
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) 'любые изменения на листе 'Больше не обновляем страницы после каждого действия Application.ScreenUpdating = False 'Отключаем события Application.EnableEvents = False With Range("Расчет[#All]").Select Selection.Copy Sheets("Лист2").Select Range("A26").Select Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("N14").Select 'Больше не обновляем страницы после каждого действия Application.ScreenUpdating = True 'Отключаем события Application.EnableEvents = True End With
End Sub
[/vba]
Но почему то теперь ругается.
Так еще и с возникнувшей проблемой - не могу посмотреть а если я удалю строки из таблицы или добавлю строки в таблицу (((( как быть. Нашел при этом одну тему хорошую My WebPage в которой было решение через создание подключения. В начале у меня все получилось (пришлось создать новый лист - туда вставить таблицу) но потом после наполнения информации на данный лист таблица начала сама изменять порядок столбцов (((( А потом подумал - а вдруг будет установлен офис старый тогда он и вовсе не обновит связи ((((
anisimovaleksandr32, Доброго времени суток. Если я вас правильно понял, то вот вам вариант. [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Лист2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:" & ws.Rows.Count).ClearContents tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteValues End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
[/vba] Удачи.
anisimovaleksandr32, Доброго времени суток. Если я вас правильно понял, то вот вам вариант. [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Лист2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:" & ws.Rows.Count).ClearContents tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteValues End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
MikeVol, спасибо огромнейшее - да вы все верно поняли Не я наверное ни когда не смогу эти макросы осилить - через запись и то совершаю ошибки ((((( Не могли бы подсказать - почему когда я данный макрос применил к файлу (не в примере) то теперь в ленте не доступно (ячейки - вставить) и не могу дополнить строку в таблицу!? Все понял почему - потому как там дальше имеются другие умные таблицы - в виду этого нет такой возможности ИЗВИНТЕ - спасибо!!!
MikeVol, спасибо огромнейшее - да вы все верно поняли Не я наверное ни когда не смогу эти макросы осилить - через запись и то совершаю ошибки ((((( Не могли бы подсказать - почему когда я данный макрос применил к файлу (не в примере) то теперь в ленте не доступно (ячейки - вставить) и не могу дополнить строку в таблицу!? Все понял почему - потому как там дальше имеются другие умные таблицы - в виду этого нет такой возможности ИЗВИНТЕ - спасибо!!!anisimovaleksandr32
Сообщение отредактировал anisimovaleksandr32 - Пятница, 20.10.2023, 19:22
MikeVol, Ваш код работает на ура НО. При добавлении/увеличении в основную таблицу "Расчет" строк на второй лист вставляет так вот Посмотрел как записывал декодер - решил дополнить [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Лист2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:" & ws.Rows.Count).ClearContents tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
[/vba] Но увы (((( тоже самое Стиль таблицы он как бы не сохраняет как есть и не продолжает ее если дополнять строки а если удалять строки то который стиль был до этого остается в пустых ячейках
MikeVol, Ваш код работает на ура НО. При добавлении/увеличении в основную таблицу "Расчет" строк на второй лист вставляет так вот Посмотрел как записывал декодер - решил дополнить [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Лист2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:" & ws.Rows.Count).ClearContents tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
[/vba] Но увы (((( тоже самое Стиль таблицы он как бы не сохраняет как есть и не продолжает ее если дополнять строки а если удалять строки то который стиль был до этого остается в пустых ячейкахanisimovaleksandr32
Сообщение отредактировал anisimovaleksandr32 - Пятница, 20.10.2023, 20:21
MikeVol, вроде вот так вот отлично получается [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Лист2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:" & ws.Rows.Count).ClearContents tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False
End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
[/vba]
При добавлении строк отлично идет и стиль повторяется
А вот при уменьшении строк в основной таблице - почему то стиль ячеек не очищается
MikeVol, вроде вот так вот отлично получается [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Лист2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:" & ws.Rows.Count).ClearContents tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _ , SkipBlanks:=False, Transpose:=False
End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
[/vba]
При добавлении строк отлично идет и стиль повторяется
А вот при уменьшении строк в основной таблице - почему то стиль ячеек не очищается anisimovaleksandr32
Сообщение отредактировал anisimovaleksandr32 - Пятница, 20.10.2023, 20:29
[/vba] это функция Excel, которую можно использовать в VBA для удаления значений и формул в диапазоне . И если прописать так эту строку [vba]
Код
ws.Rows("26:" & ws.Rows.Count).Clear
[/vba] то все отлично работает с одним лишь НО она тогда формулы оставляет (но при этом сохраняет и стиль в ячейках и при удалении строк и при увеличении строк)
Я понимаю что команда [vba]
Код
ws.Rows("26:" & ws.Rows.Count).ClearContents
[/vba] это функция Excel, которую можно использовать в VBA для удаления значений и формул в диапазоне . И если прописать так эту строку [vba]
Код
ws.Rows("26:" & ws.Rows.Count).Clear
[/vba] то все отлично работает с одним лишь НО она тогда формулы оставляет (но при этом сохраняет и стиль в ячейках и при удалении строк и при увеличении строк)
anisimovaleksandr32, Подождите, что вы мне голову морочите? У вас в теме что прописано, правильно - дублировать таблицу как значения (без формул). Что же вам тогда тут не подходит? [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Ðàñ÷åò") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Ëèñò2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:26").ClearContents ws.Rows("27:" & ws.Rows.Count).Clear tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteValues ws.Cells(26, 1).PasteSpecial Paste:=xlPasteFormats End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
Дублирование основной таблицы на другой лист (только знач)
anisimovaleksandr32, Подождите, что вы мне голову морочите? У вас в теме что прописано, правильно - дублировать таблицу как значения (без формул). Что же вам тогда тут не подходит? [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Ðàñ÷åò") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Ëèñò2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:26").ClearContents ws.Rows("27:" & ws.Rows.Count).Clear tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteValues ws.Cells(26, 1).PasteSpecial Paste:=xlPasteFormats End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
Я если честно уже в ссылки погрузился My WebPage - понимаю что ответ то лежит на поверхности но сообразить при этом не могу как это реализовать (чтоб стиль был и формул не было)
Я если честно уже в ссылки погрузился My WebPage - понимаю что ответ то лежит на поверхности но сообразить при этом не могу как это реализовать (чтоб стиль был и формул не было)
MikeVol, поспешил с ответом на 100% На листе2 после вставки скопированной таблицы - ниже нее имеется ряд другой информации (которая должна размещаться под таблицей). В данном макросе: [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Лист2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:26").ClearContents ws.Rows("27:" & ws.Range("C27").End(xlDown).Row).Clear ' Привязался к стодбцу C ' ws.Rows("27:" & ws.Rows.Count).Clear tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteValues ws.Cells(26, 1).PasteSpecial Paste:=xlPasteFormats End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
[/vba]
Все удовлетворяет но как только оператор увеличивает количество строк в основной таблице То информация находящая под таблицей (а это к примеру объединенная ячейка через две строки после вставки скопированной таблицы) - ругается на код картинки для клана pw А если не объединять ячейки под таблицей то он просто удаляет информацию (((( Решил посмотреть как будет прописан код если использовать макро декодер [vba]
Код
Sub Макрос1() ' ' Макрос1 Макрос '
' Range("Расчет[#All]").Copy Sheets("Лист4").Range("A10").Insert Shift:=xlDown End Sub
[/vba] Применил его на лист 4 и видно что есть смещение при вставке
MikeVol, поспешил с ответом на 100% На листе2 после вставки скопированной таблицы - ниже нее имеется ряд другой информации (которая должна размещаться под таблицей). В данном макросе: [vba]
Код
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Лист2") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("26:26").ClearContents ws.Rows("27:" & ws.Range("C27").End(xlDown).Row).Clear ' Привязался к стодбцу C ' ws.Rows("27:" & ws.Rows.Count).Clear tbl.Range.Copy ws.Cells(26, 1).PasteSpecial Paste:=xlPasteValues ws.Cells(26, 1).PasteSpecial Paste:=xlPasteFormats End If
Application.CutCopyMode = False Application.ScreenUpdating = True End Sub
[/vba]
Все удовлетворяет но как только оператор увеличивает количество строк в основной таблице То информация находящая под таблицей (а это к примеру объединенная ячейка через две строки после вставки скопированной таблицы) - ругается на код картинки для клана pw А если не объединять ячейки под таблицей то он просто удаляет информацию (((( Решил посмотреть как будет прописан код если использовать макро декодер [vba]
Код
Sub Макрос1() ' ' Макрос1 Макрос '
' Range("Расчет[#All]").Copy Sheets("Лист4").Range("A10").Insert Shift:=xlDown End Sub
[/vba] Применил его на лист 4 и видно что есть смещение при вставкеanisimovaleksandr32
anisimovaleksandr32, Доброго времени суток. Приложите файл пример с максимально схожей структурой файла оригинала (таблицу с теми данными что находятся под ней), максимально схожий. Без конфидинциальной информацией.
anisimovaleksandr32, Доброго времени суток. Приложите файл пример с максимально схожей структурой файла оригинала (таблицу с теми данными что находятся под ней), максимально схожий. Без конфидинциальной информацией.MikeVol
MikeVol, вот сам файл куда хотел потом применить данный макрос Лист В35 основная таблица для расчета - которую нужно будет потом скопировать и вставить на листе Заключение
MikeVol, вот сам файл куда хотел потом применить данный макрос Лист В35 основная таблица для расчета - которую нужно будет потом скопировать и вставить на листе Заключениеanisimovaleksandr32
оператор увеличивает количество строк в основной таблице
Если не более 4-х строк то ещё терпимо, но если больше то уже придётся пересматривать полностью вопрос. В модуль Листа B35: [vba]
Код
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set Target = Range("A1") If Target = "" Then Exit Sub Application.ActiveSheet.Name = VBA.Left(Target, 31) Exit Sub End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("ЗАКЛЮЧЕНИЕ") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("50:50").ClearContents ws.Rows("51:" & ws.Range("C51").End(xlDown).Row).Clear tbl.Range.Copy ws.Cells(50, 1).PasteSpecial Paste:=xlPasteValues ws.Cells(50, 1).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False
ws.Range("A51:A" & ws.Range("C51").End(xlDown).Row).FormulaR1C1 = "=INDEX(В35!R16C3:R100C3, ROW(), COLUMN())" End If
Application.ScreenUpdating = True End Sub
[/vba] Код отрабатывает на вашем последнем файле примере без ошибок.
anisimovaleksandr32, Всё зависит от того на сколько
оператор увеличивает количество строк в основной таблице
Если не более 4-х строк то ещё терпимо, но если больше то уже придётся пересматривать полностью вопрос. В модуль Листа B35: [vba]
Код
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range) Set Target = Range("A1") If Target = "" Then Exit Sub Application.ActiveSheet.Name = VBA.Left(Target, 31) Exit Sub End Sub
Private Sub Worksheet_Change(ByVal Target As Range) Dim tbl As ListObject: Set tbl = ListObjects("Расчет") Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("ЗАКЛЮЧЕНИЕ") Application.ScreenUpdating = False
If Not Intersect(Target, tbl.DataBodyRange) Is Nothing Then ws.Rows("50:50").ClearContents ws.Rows("51:" & ws.Range("C51").End(xlDown).Row).Clear tbl.Range.Copy ws.Cells(50, 1).PasteSpecial Paste:=xlPasteValues ws.Cells(50, 1).PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False
ws.Range("A51:A" & ws.Range("C51").End(xlDown).Row).FormulaR1C1 = "=INDEX(В35!R16C3:R100C3, ROW(), COLUMN())" End If
Application.ScreenUpdating = True End Sub
[/vba] Код отрабатывает на вашем последнем файле примере без ошибок.MikeVol
Ученик. Одесса - Украина
Сообщение отредактировал MikeVol - Понедельник, 23.10.2023, 14:12
MikeVol, понял "Если не более 4-х строк то ещё терпимо" - да видать без запроса и Power Query не обойтись ((((. А если офис старый установлен ((((( то пф [vba]
Код
Sub Макрос1() ' ' Макрос1 Макрос '
' Range("Расчет[#All]").Copy Sheets("Лист4").Range("A10").Insert Shift:=xlDown End Sub
[/vba] Так будет куда эффективнее тогда - только прописать через активацию листа (если это позволительно будет для эффективности - ну край через кнопку).
MikeVol, понял "Если не более 4-х строк то ещё терпимо" - да видать без запроса и Power Query не обойтись ((((. А если офис старый установлен ((((( то пф [vba]
Код
Sub Макрос1() ' ' Макрос1 Макрос '
' Range("Расчет[#All]").Copy Sheets("Лист4").Range("A10").Insert Shift:=xlDown End Sub
[/vba] Так будет куда эффективнее тогда - только прописать через активацию листа (если это позволительно будет для эффективности - ну край через кнопку).anisimovaleksandr32
anisimovaleksandr32, У вас разметка страницы такая, можно ещё 2 строки дать в запас. Выделяете руками строки 84-85 добавить строки. Далее выледяете строки 93-94 удалить строки, так у вас ещё две строки в запасе будет, было 4 стало 6 строк. Там даже
не поможет так как из-за разметки страницы. Подумайте ещё.
anisimovaleksandr32, У вас разметка страницы такая, можно ещё 2 строки дать в запас. Выделяете руками строки 84-85 добавить строки. Далее выледяете строки 93-94 удалить строки, так у вас ещё две строки в запасе будет, было 4 стало 6 строк. Там даже
MikeVol, не поможет - да как не поможет то Смотрите как он справляется на ура и красиво (правда я вот так и не смог применить этот Power Query и запрос создать - к своему файлу) прикладываю пример На листе 1 по типу основная таблица на лист Sheet1 информация дублируется
MikeVol, не поможет - да как не поможет то Смотрите как он справляется на ура и красиво (правда я вот так и не смог применить этот Power Query и запрос создать - к своему файлу) прикладываю пример На листе 1 по типу основная таблица на лист Sheet1 информация дублируетсяanisimovaleksandr32
как только оператор увеличивает количество строк в основной таблице
??? К примеру, ваш оператор добавил ещё 5-6 строк в основную таблицу и куда ваша разметка страницы ушла? Вы меня не слышите что я вам говорю. Пробуйте добавить ещё эти 5-6 строк и увидите результат! Я пас.
anisimovaleksandr32, Я извиняюсь конечно. А как же
как только оператор увеличивает количество строк в основной таблице
??? К примеру, ваш оператор добавил ещё 5-6 строк в основную таблицу и куда ваша разметка страницы ушла? Вы меня не слышите что я вам говорю. Пробуйте добавить ещё эти 5-6 строк и увидите результат! Я пас.MikeVol
MikeVol, К примеру, ваш оператор добавил ещё 5-6 строк в основную таблицу и куда ваша разметка страницы ушла Да хоть 10-ть данный лист только для распечатывания - а если даже эта таблица уйдет на следующий лист - то всегда ведь можно применить не так ли!? СПАСИБО огромное за отзывчивость и помощь...
MikeVol, К примеру, ваш оператор добавил ещё 5-6 строк в основную таблицу и куда ваша разметка страницы ушла Да хоть 10-ть данный лист только для распечатывания - а если даже эта таблица уйдет на следующий лист - то всегда ведь можно применить не так ли!? СПАСИБО огромное за отзывчивость и помощь...anisimovaleksandr32
Сообщение отредактировал anisimovaleksandr32 - Понедельник, 23.10.2023, 14:45
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
поспешил с ответом на 100%
но как только оператор увеличивает количество строк в основной таблице 
