Столбец А преобразовать в строки по столбцу В

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Столбец А преобразовать в строки по столбцу В (Макросы/Sub)

ABkeeper

Дата: Среда, 04.12.2019, 11:40 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 2

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Здравствуйте.
Требуется модифицировать скрипт (создавался для другого задания - он работает корректно только с 4 строками в сегменте, а сейчас их может быть 12)
Если не получится, то создать новый

[vba]

Код

Sub proba()
Dim I As Long, J As Long, LastRow As Long, K As Integer
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
J = 1
For I = 2 To LastRow
If Cells(I, 2) <> "" Then
J = J + 1: Cells(J, "I") = Format(Cells(I, 2), "*0.00"): K = 0
End If
K = K + 1: Cells(J, 4 + K) = Cells(I, 1)
Next
End Sub

[/vba]

По сути необходимо транспонировать данные столбца B по данным в столбце A
Пример файла прилагается.

Спасибо.

К сообщению приложен файл: 7297564.xlsx (9.4 Kb)

Сообщение отредактировал ABkeeper - Среда, 04.12.2019, 14:47

Ответить

_Boroda_

Дата: Среда, 04.12.2019, 17:05 | Сообщение № 2

Группа: Админы

Ранг: Местный житель

Сообщений: 16718

Репутация: 6505 ±

Замечаний: ±

2003; 2007; 2010; 2013 RUS

Так нужно?
[vba]

Код

Sub tt()
    r0_ = 3
    c00_ = 1
    c01_ = 4
    nc_ = Cells(r0_ - 1, Columns.Count).End(1).Column - c01_ + 1
    nr_ = Cells(Rows.Count, c01_).End(3).Row - r0_ + 1
    ar = Cells(r0_, c01_).Resize(nr_, nc_)
    n_ = WorksheetFunction.CountA(Cells(r0_, c01_ + 1).Resize(nr_, nc_ - 1))
    ReDim ar1(1 To n_, 1 To 2)
    k_ = 1
    For i = 1 To nr_
        ar1(k_, 1) = ar(i, 1)
        For j = 2 To nc_
            If ar(i, j) <> "" Then
                ar1(k_, 2) = ar(i, j)
                k_ = k_ + 1
            Else
                Exit For
            End If
        Next j
'        k_ = k_ - 1
    Next i
    Cells(r0_, c00_).Resize(Rows.Count - r0_, 2).Clear
    Cells(r0_, c00_).Resize(n_, 2) = ar1
End Sub

[/vba]

К сообщению приложен файл: 7297564_1.xlsm (17.3 Kb)

Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

Ответить

Kuzmich

Дата: Среда, 04.12.2019, 17:45 | Сообщение № 3

Группа: Проверенные

Ранг: Ветеран

Сообщений: 714

Репутация: 157 ±

Замечаний: 0% ±

Excel 2003

У меня так получилось, при условии, что область переноса очищена
[vba]

Код

Sub ReTable()
Dim i As Long
Dim iLastRow As Long
Dim Col As Integer
Dim stroka As Integer
iLastRow = Cells(Rows.Count, "B").End(xlUp).Row
    stroka = 3
  For i = 3 To iLastRow
    Col = 4
      Cells(stroka, Col) = Cells(i, "A")
    Do
      Col = Col + 1
      Cells(stroka, Col) = Cells(i, "B")
      i = i + 1
    Loop While Cells(i, "A") = "" And i < iLastRow + 1
      stroka = stroka + 1
      i = i - 1
  Next
End Sub

[/vba]

Ответить

boa

Дата: Среда, 04.12.2019, 17:46 | Сообщение № 4

Группа: Друзья

Ранг: Ветеран

Сообщений: 559

Репутация: 167 ±

Замечаний: 0% ±

365

ABkeeper,
ну или так
[vba]

Код

Sub proba()
  Dim iCol&, iRow&, LastRow&, i&
  Dim shOut As Worksheet: Set shOut = ThisWorkbook.ActiveSheet
  Dim shIn As Worksheet:  Set shIn = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

  LastRow = shOut.Cells(shOut.Rows.Count, 2).End(xlUp).Row
  iRow = 2  ' строка с которой начинаем заполнение
  For i = 3 To LastRow
    iCol = 1 'колонка с которой начинаем заполнение
    shIn.Cells(iRow, iCol) = shOut.Cells(i, 1)
    Do: iCol = iCol + 1
      shIn.Cells(iRow, iCol) = shOut.Cells(i, 2)
      i = i + 1
      If i > LastRow Then GoTo ExitSub
    Loop Until shOut.Cells(i, 1) <> ""
    i = i - 1
    iRow = iRow + 1
  Next

ExitSub:
    shIn.Cells.EntireColumn.AutoFit
End Sub

[/vba]
шапку добавите сами?