Здравствуйте, уважаемые форумчане! Помогите, пожалуйста, разобраться с проблемой, долго не могу разобраться... На листе выделяю с помощью CTRL+ЛКМ произвольное (заранее неизвестное) количество ячеек. Далее определяю номера строк выделенных ячеек. По этим номерам строк необходимо диапазоны фиксированной ширины скопировать, например, в строку 40 и ниже данного листа. Написал код, но он не работает, т.к. "Union" не воспринимает текст из переменной. Метод копирования построчно не подойдет, т.к. в итоге вставка будет происходить другим кодом в другой книге. Подскажите, пожалуйста, в чем у меня ошибка и как можно преодолеть ограничение "Union" в 30 аргументов (выделенных ячеек может быть больше 30)? Или может быть есть более оптимальный быстроработающий вариант кода? Заранее спасибо. [vba]
Код
Sub test2() Dim element As Range 'Dim a As String Dim a Dim b Dim i As Integer Dim multirng As Range b = ", " i = 1 For Each element In Selection i = i + 1 a = a & "Range(Cells(" & element.Row & ", 1), Cells(" & element.Row & ", 7))" & b Next a = Left(a, Len(a) - 2) 'Range("B40") = a Set multirng = Union(a) multirng.Copy Range(Cells(40, 1), Cells(40 + i - 1, 7)).Paste End Sub
[/vba]
Здравствуйте, уважаемые форумчане! Помогите, пожалуйста, разобраться с проблемой, долго не могу разобраться... На листе выделяю с помощью CTRL+ЛКМ произвольное (заранее неизвестное) количество ячеек. Далее определяю номера строк выделенных ячеек. По этим номерам строк необходимо диапазоны фиксированной ширины скопировать, например, в строку 40 и ниже данного листа. Написал код, но он не работает, т.к. "Union" не воспринимает текст из переменной. Метод копирования построчно не подойдет, т.к. в итоге вставка будет происходить другим кодом в другой книге. Подскажите, пожалуйста, в чем у меня ошибка и как можно преодолеть ограничение "Union" в 30 аргументов (выделенных ячеек может быть больше 30)? Или может быть есть более оптимальный быстроработающий вариант кода? Заранее спасибо. [vba]
Код
Sub test2() Dim element As Range 'Dim a As String Dim a Dim b Dim i As Integer Dim multirng As Range b = ", " i = 1 For Each element In Selection i = i + 1 a = a & "Range(Cells(" & element.Row & ", 1), Cells(" & element.Row & ", 7))" & b Next a = Left(a, Len(a) - 2) 'Range("B40") = a Set multirng = Union(a) multirng.Copy Range(Cells(40, 1), Cells(40 + i - 1, 7)).Paste End Sub
Sub test2() Dim element As Range Dim multirng As Range For Each element In Selection If multirng Is Nothing Then Set multirng = Cells(element.Row, 1).Resize(1, 7) Else Set multirng = Union(multirng, Cells(element.Row, 1).Resize(1, 7)) End If Next multirng.Copy Cells(40, 1) End Sub
[/vba]
Здравствуйте. Можно так попробовать [vba]
Код
Sub test2() Dim element As Range Dim multirng As Range For Each element In Selection If multirng Is Nothing Then Set multirng = Cells(element.Row, 1).Resize(1, 7) Else Set multirng = Union(multirng, Cells(element.Row, 1).Resize(1, 7)) End If Next multirng.Copy Cells(40, 1) End Sub
Выявилась интересная особенность... Если копировать один связанный диапазон, то формулы копируются (столбцы C, F). Если выделенные ячейки не связаны, то копируются только значения. Можно это ограничение как то преодолеть?
Выявилась интересная особенность... Если копировать один связанный диапазон, то формулы копируются (столбцы C, F). Если выделенные ячейки не связаны, то копируются только значения. Можно это ограничение как то преодолеть?Markovich
Так будут копироваться значения. Добавила ещё очистку диапазона, начиная от ячейки А40, и буфера обмена, чтобы убиралась пунктирная рамка [vba]
Код
Sub test2() Dim element As Range Dim multirng As Range For Each element In Selection If multirng Is Nothing Then Set multirng = Cells(element.Row, 1).Resize(1, 7) Else Set multirng = Union(multirng, Cells(element.Row, 1).Resize(1, 7)) End If Next Cells(40, 1).Resize(1, 7).CurrentRegion.ClearContents multirng.Copy Cells(40, 1).PasteSpecial xlPasteValuesAndNumberFormats Application.CutCopyMode = False End Sub
[/vba]
Так будут копироваться значения. Добавила ещё очистку диапазона, начиная от ячейки А40, и буфера обмена, чтобы убиралась пунктирная рамка [vba]
Код
Sub test2() Dim element As Range Dim multirng As Range For Each element In Selection If multirng Is Nothing Then Set multirng = Cells(element.Row, 1).Resize(1, 7) Else Set multirng = Union(multirng, Cells(element.Row, 1).Resize(1, 7)) End If Next Cells(40, 1).Resize(1, 7).CurrentRegion.ClearContents multirng.Copy Cells(40, 1).PasteSpecial xlPasteValuesAndNumberFormats Application.CutCopyMode = False End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
