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

Вход

Регистрация

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

 

= Мир MS Excel/Столбец А преобразовать в строки по столбцу В - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Столбец А преобразовать в строки по столбцу В (Макросы/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
 
Ответить
СообщениеЗдравствуйте.
Требуется модифицировать скрипт (создавался для другого задания - он работает корректно только с 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
Пример файла прилагается.

Спасибо.

Автор - ABkeeper
Дата добавления - 04.12.2019 в 11:40
_Boroda_ Дата: Среда, 04.12.2019, 17:05 | Сообщение № 2
Группа: Модераторы
Ранг: Местный житель
Сообщений: 15640
Репутация: 6114 ±
Замечаний: 0% ±

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
 
Ответить
СообщениеТак нужно?
[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]

Автор - _Boroda_
Дата добавления - 04.12.2019 в 17:05
Kuzmich Дата: Среда, 04.12.2019, 17:45 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 430
Репутация: 88 ±
Замечаний: 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]
 
Ответить
СообщениеУ меня так получилось, при условии, что область переноса очищена
[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]

Автор - Kuzmich
Дата добавления - 04.12.2019 в 17:45
boa Дата: Среда, 04.12.2019, 17:46 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 428
Репутация: 117 ±
Замечаний: 0% ±

2013, 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]
шапку добавите сами?




Сообщение отредактировал boa - Среда, 04.12.2019, 17:48
 
Ответить
Сообщение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]
шапку добавите сами?

Автор - boa
Дата добавления - 04.12.2019 в 17:46
ABkeeper Дата: Среда, 04.12.2019, 20:13 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 2
Репутация: 0 ±
Замечаний: 0% ±

Excel 2016
boa,
Огромное спасибо.

Всё работает.
Шапку поправил... :-)

Ещё раз, СПАСИБО!!
 
Ответить
Сообщениеboa,
Огромное спасибо.

Всё работает.
Шапку поправил... :-)

Ещё раз, СПАСИБО!!

Автор - ABkeeper
Дата добавления - 04.12.2019 в 20:13
boa Дата: Среда, 04.12.2019, 22:06 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 428
Репутация: 117 ±
Замечаний: 0% ±

2013, 365
ABkeeper,
У Александра(_Boroda_), более скоростной вариант, расcчитан на большие массивы, рекомендую изучить.




Сообщение отредактировал boa - Четверг, 05.12.2019, 10:05
 
Ответить
СообщениеABkeeper,
У Александра(_Boroda_), более скоростной вариант, расcчитан на большие массивы, рекомендую изучить.

Автор - boa
Дата добавления - 04.12.2019 в 22:06
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Столбец А преобразовать в строки по столбцу В (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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