Перенос ячеек на листе

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

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

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос ячеек на листе (Макросы/Sub)

fairylive

Дата: Вторник, 27.09.2016, 19:01 | Сообщение № 1

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

Ранг: Форумчанин

Сообщений: 122

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

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

Excel 2016

Всем привет. Споткнулся тут с простой задачей. Завис уже часа на три.
Вобщем есть таблица исходных данных в виде 1 строки и 100500 столбцов. Нужно сделать таблицу в два столбца и 100500/2 строк. Принцип такой: первые две ячейки остаются на месте, следующая пара ячеек переезжает под них и так далее.
Прикладываю свой файл. Там какой-то из последних сырых вариантов.

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

Ответить

Pelena

Дата: Вторник, 27.09.2016, 19:35 | Сообщение № 2

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

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

Сообщений: 19187

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

Замечаний: ±

Excel 365 & Mac Excel

Здравствуйте.
А формулой не хотите?

Код

=ИНДЕКС($C$1:$ADD$1;СТРОКА(A1)*2-1)

Потом можно Копировать/Вставить как значения

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

"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816

Ответить

RAN

Дата: Вторник, 27.09.2016, 19:46 | Сообщение № 3

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

Ранг: Экселист

Сообщений: 5660

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

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

2010

[vba]

Код

Sub qq()
j = 2
    For i = 3 To Columns(Columns.Count).End(xlToLeft).Column Step 2
        Cells(j, 1).Resize(, 2).Value = Cells(1, i).Resize(, 2).Value
        j = j + 1
    Next
End Sub

[/vba]

Быть или не быть, вот в чем загвоздка!

Ответить

Karataev

Дата: Вторник, 27.09.2016, 19:54 | Сообщение № 4

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

Ранг: Старожил

Сообщений: 1334

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

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

Excel

[vba]

Код

Sub Разнести_по_строкам()

    Dim arr1(), arr2(), lc As Long, i As Long, j As Long

    lc = Rows(1).Find(What:="*", LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False _
        , SearchFormat:=False).Column
    arr1() = Range("A1").Resize(1, lc).Value
    ReDim arr2(1 To UBound(arr1, 2) / 2, 1 To 2)

    i = 0
    For j = 1 To UBound(arr1, 2) Step 2
        i = i + 1
        arr2(i, 1) = arr1(1, j)
        arr2(i, 2) = arr1(1, j + 1)
    Next

    Range("A1").Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2()

End Sub

[/vba]

Ответить

_Boroda_

Дата: Вторник, 27.09.2016, 19:59 | Сообщение № 5

Группа: Модераторы

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

Сообщений: 16675

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

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

2003; 2007; 2010; 2013 RUS

И такой простенький вариант
[vba]

Код

Sub упорядочить()
    For i = 1 To Cells(1, Columns.Count).End(xlToLeft).Column Step 2
        n_ = Not n_
        Cells(2, Int(i / 4) * 2 + 1).Offset(1 + n_).Resize(, 2) = Cells(1, i).Resize(, 2).Value
    Next i
End Sub

[/vba]

Если добавить нужностей всяких, то
[vba]

Код

Sub упорядочить()
    Dim n_ As Boolean
    Application.ScreenUpdating = 0
    cal_ = Application.Calculation
    Application.Calculation = xlCalculationManual
    c1_ = Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To c1_ Step 2
        n_ = Not n_
        Cells(2, Int(i / 4) * 2 + 1).Offset(1 + n_).Resize(, 2) = Cells(1, i).Resize(, 2).Value
    Next i
    Application.Calculation = cal_
    Application.ScreenUpdating = 1
    MsgBox "Всё"
End Sub

[/vba]

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

Ответить

fairylive

Дата: Среда, 28.09.2016, 14:07 | Сообщение № 6

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

Ранг: Форумчанин

Сообщений: 122

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

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

Excel 2016

Всем большое спасибо! Пока наиболее понятный вариант от товарища RAN. Так даже проще чем я думал.

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос ячеек на листе (Макросы/Sub)

Страница 1 из 1
1