Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Трнспонирование данных из столба в строки блоками на другой лист, Как реализовать цикл?
 
#1
25.06.2019 14:29:01
Здравствуйте. Помогите, пожалуйста загнать в цикл следующий код.
Код
Sub транспонирование()
Sheets("Один").Select
Range("A1").Select
Selection.End(xlDown).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Два").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, transpose:=True
Sheets("Один").Select
Selection.Offset(9, 0).Select
Selection.Copy
Sheets("Два").Select
Range("A" & Cells.Rows.Count).End(xlUp).Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, transpose:=True
Sheets("Один").Select
Selection.Offset(9, 0).Select
Selection.Copy
Sheets("Два").Select
ActiveCell.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, transpose:=True

End Sub

Что он делает? Берет данные с первого столбца листа "Один" и вставляет их с транспонированием на лист "Два". Итог можно увидеть на листе "Результат" или запустив макрос.

Цикл нужен такой, чтобы работа макроса заканчивалась на последнем блоке данных столбца "А" листа "Один". То есть, сейчас там данные заканчиваются на ячейке "А27", но строк может быть куда больше.
 
 
 
#2
25.06.2019 14:37:23
Если все блоки одного размера, то проще всего взять Sheets("Один").UsedRange.rows.count, разделить на размер блока (в данном случае 9) и получить количество повторений. Потом делать цикл.
А можно и совсем по другому.
 
 
 
#3
25.06.2019 14:50:14
По-другому :)  :
Код
Sub qqq()
    Dim lr1  As Long   'строка на листе 1
    Dim lr2  As Long   'строка на листе 2
    Dim lc2  As Long   'столбец на листе 2
    lr2 = 1
    lc2 = 1
    ThisWorkbook.Worksheets("Один").Activate
For lr1 = 2 To Cells(Rows.Count, 1).End(xlUp).Row
  If Worksheets("Один").Cells(lr1, 1).Value <> "" Then
     Worksheets("Два").Cells(lr2, lc2).Value = Worksheets("Один").Cells(lr1, 1).Value
     lc2 = lc2 + 1
  Else
     lr2 = lr2 + 1
     lc2 = 1
  End If
Next lr1
End Sub
 
 
 
#4
25.06.2019 15:02:08
Цитата
_Igor_61 написал:
По-другому
Опередил, однако!
 
 
 
#5
25.06.2019 15:04:40
:D  
 
 
 
#6
25.06.2019 15:20:29
Мартын,  _Igor_61
Благодарю!
Изменено: andronus - 25.06.2019 15:20:40
 
 
 
Страницы: 1
Наверх