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

Вход

Регистрация

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

 

= Мир MS Excel/копирование несвязанных диапазонов по выделенным ячейкам - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » копирование несвязанных диапазонов по выделенным ячейкам (Макросы/Sub)
копирование несвязанных диапазонов по выделенным ячейкам
Markovich Дата: Четверг, 08.12.2022, 11:51 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Здравствуйте, уважаемые форумчане!
Помогите, пожалуйста, разобраться с проблемой, долго не могу разобраться...
На листе выделяю с помощью 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]
К сообщению приложен файл: 7907987.xlsb(18.0 Kb)


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

Автор - Markovich
Дата добавления - 08.12.2022 в 11:51
Pelena Дата: Пятница, 09.12.2022, 09:34 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 18707
Репутация: 4260 ±
Замечаний: ±

Excel 2016 & Mac Excel
Здравствуйте.
Можно так попробовать
[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
[/vba]
К сообщению приложен файл: 9794571.xlsb(16.6 Kb)


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеЗдравствуйте.
Можно так попробовать
[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
[/vba]

Автор - Pelena
Дата добавления - 09.12.2022 в 09:34
Markovich Дата: Пятница, 09.12.2022, 11:45 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Pelena, здравствуйте. Код работает так как и было задумано. Не первый раз мне помогаете, большое Вам спасибо!
 
Ответить
СообщениеPelena, здравствуйте. Код работает так как и было задумано. Не первый раз мне помогаете, большое Вам спасибо!

Автор - Markovich
Дата добавления - 09.12.2022 в 11:45
Markovich Дата: Пятница, 09.12.2022, 14:04 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 48
Репутация: 0 ±
Замечаний: 0% ±

Excel 2019
Выявилась интересная особенность... Если копировать один связанный диапазон, то формулы копируются (столбцы C, F). Если выделенные ячейки не связаны, то копируются только значения. Можно это ограничение как то преодолеть?
К сообщению приложен файл: 0382698.xlsb(17.3 Kb)


Сообщение отредактировал Markovich - Пятница, 09.12.2022, 14:05
 
Ответить
СообщениеВыявилась интересная особенность... Если копировать один связанный диапазон, то формулы копируются (столбцы C, F). Если выделенные ячейки не связаны, то копируются только значения. Можно это ограничение как то преодолеть?

Автор - Markovich
Дата добавления - 09.12.2022 в 14:04
Pelena Дата: Пятница, 09.12.2022, 15:33 | Сообщение № 5
Группа: Админы
Ранг: Местный житель
Сообщений: 18707
Репутация: 4260 ±
Замечаний: ±

Excel 2016 & Mac Excel
Так будут копироваться значения. Добавила ещё очистку диапазона, начиная от ячейки А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]


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
СообщениеТак будут копироваться значения. Добавила ещё очистку диапазона, начиная от ячейки А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]

Автор - Pelena
Дата добавления - 09.12.2022 в 15:33
Мир MS Excel » Вопросы и решения » Вопросы по VBA » копирование несвязанных диапазонов по выделенным ячейкам (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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