Зеркальный перенос строк по горизонтали

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

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

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Зеркальный перенос строк по горизонтали (Макросы/Sub)

Gangrena

Дата: Суббота, 17.10.2015, 16:49 | Сообщение № 1

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

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

Сообщений: 6

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

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

Excel 2010

Здравствуйте! Подскажите простенький макрос, чтобы из

аааа бббб аааа бббб аааа бббб
уууу 2222 ууууу 2222 уууу 2222
жжжж 33 жжжж 33 жжжж 333
фффф 888 фффф 888 фффф

получилось

фффф 888 фффф 888 фффф
жжжж 33 жжжж 33 жжжж 333
уууу 2222 ууууу 2222 уууу 2222
аааа бббб аааа бббб аааа бббб

Спасибо!

Ответить

Roman777

Дата: Суббота, 17.10.2015, 18:17 | Сообщение № 2

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

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

Сообщений: 980

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

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

Excel 2007, Excel 2013

Gangrena, можно так:
[vba]

Код

Sub zerk()
Dim i As Long
Dim i_n As Long
Dim rng As Range
Dim k As Long
Dim rng1, rng2
Set rng = Application.InputBox("Выбирите область в которой необходимо отзеркалить строки", _
"Область", Type:=8)
i = rng.Cells(1, 1).Row
i_n = rng.Cells(Rows(rng.Rows.Count).Row, 1).Row
For j = i To (i_n + i) \ 2
rng1 = Rows(j)
rng2 = Rows(i_n - k)
Rows(j) = rng2
Rows(i_n - k) = rng1
k = k + 1
Next j
End Sub

[/vba]
Но данный способ наверное не самый быстрый...)

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

Много чего не знаю!!!!

Ответить

KSV

Дата: Суббота, 17.10.2015, 18:20 | Сообщение № 3

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

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

Сообщений: 770

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

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

Excel 2013

как вариант: [vba]

Код

Private Sub ReverseRange()
    Dim i&, n&, v1(), v2()
    With Selection
        n = .Rows.Count
        For i = 1 To n \ 2
            v1 = .Rows(i).Value
            v2 = .Rows(n).Value
            .Rows(i) = v2
            .Rows(n) = v1
            n = n - 1
        Next
    End With
End Sub

[/vba] Выделите диапазон, который нужно зеркально отобразить по вертикали, и нажмите кнопку.

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

KSV.VBA@gmail.com
Яндекс.Деньги: 410011921213333

Сообщение отредактировал KSV - Суббота, 17.10.2015, 18:30

Ответить

Gangrena

Дата: Суббота, 17.10.2015, 18:55 | Сообщение № 4

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

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

Сообщений: 6

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

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

Excel 2010

Цитата Roman777, 17.10.2015 в 18:17, в сообщении № 2

способ наверное не самый быстрый...)

Спасибо за макрос, кладу в копилку! :)

Цитата KSV, 17.10.2015 в 18:20, в сообщении № 3

и нажмите кнопку.

Здорово, благодарю! Очень замечательно!:)

Ответить

МВТ

Дата: Суббота, 17.10.2015, 20:56 | Сообщение № 5

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

Ранг: Обитатель

Сообщений: 476

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

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

Excel 2007

Теоретически будет быстрее работать на больших объемах [vba]

Код

Sub ReverseRange()
     Dim i As Long, n As Long, mid As Long, v1, v2
     With Selection
        n = .Rows.Count
        v1 = .Value
        If n Mod 2 = 0 Then mid = 0 Else mid = Round(n \ 2) + 1
        ReDim v2(1 To n, 1 To 1)
        For i = 1 To Round(n + 0.5) \ 2
            v2(i, 1) = v1(n - i + 1, 1)
            v2(n - i + 1, 1) = v1(i, 1)
         Next
         If mid <> 0 Then v2(mid, 1) = v1(mid, 1)
         .Value = v2
     End With
End Sub

[/vba]

Ответить

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Зеркальный перенос строк по горизонтали (Макросы/Sub)

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