Страницы: 1
RSS
Копирование данных диапазона состоящего из 10 ячеек с одного листа на другой с траспонированием построчно
 
Здравствуйте, уважаемые эксперты.
Подскажите, пожалуйста, как написать процедуру повторяющегося выбора и копирования ячеек и последующей вставки этих ячеек на новый лист с транспонированием.

На листе Sheet1 В столбце A имеем 3 диапазона заполненных ячеек, разделенных пустой строкой (файл Sample3.xlsx приложен).
Необходимо поочередно скопировать каждый диапазон и вставить его со специальной вставкой на новый лист (Sheet2) и транспонировать строки в столбцы. С помощью рекордера макросов и нехитрых манипуляций с кодом удалось получить макрос для 3 срабатываний (файл transpose3.txt).
Хотелось бы сделать такой макрос для любого числа таких диапазонов

Спасибо
С уважением,
Сергей
 
jocker_y, приветствую, у вас название темы с нарушением и любую помощь модератор скроет так как по факту у вас вопрос не о циклах, а тема согласно правилам должна отражать суть задачи (копирование данных диапазонов с одного листа на другой с  траспонированием)...
из правил
Цитата
2.1. Название темы должно отражать смысл проблемы. Темы с названиями "Помогите", "Help", "Срочно", "Нужен макрос" - плохая идея. Модераторы имеют право переименовать, удалить или закрыть такие темы без предупреждения.
а пока думаете о новом названии (его нужно предложить здесь в тесте сообщения например первого) копируемые диапазоны всегда одной размерности? если да то макрос уже готов.
видимо автору не до темы...
Тема: Копирование данных диапазона состоящего из 10 ячеек с одного листа на другой с траспонированием построчно
Код
Sub Copy()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim lr As Long
k = 0
With Worksheets(1)
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To lr Step 10
        .Range("A" & i & ":A" & i + 9).Copy
        k = k + 1
        DoEvents
        Worksheets(2).Range("A" & k).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Next i
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Изменено: Mershik - 17.09.2020 16:36:15
Не бойтесь совершенства. Вам его не достичь.
 
Mershik огромное спасибо, код реально хорош!  8)  

Сорри по поводу темы, в следующий раз буду внимательнее.
Страницы: 1
Наверх