Здравствуйте, уважаемые форумчане! Помогите, пожалуйста, разобраться с проблемой, долго не могу разобраться... На листе выделяю с помощью 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