Страницы: 1
RSS
Зеркальное отображение информации, Нужна помощь профессионалов
 
Добрый день.
На старой ветке форума нашёл макрос автора tolstak, который позволяет зеркально отобразить информацию по двум осям.
Т.Е. - исходная информация 123     трансформируется в 654
                                                456                                        321
Мне необходимо отзеркалить относительной одной, вертикальной оси. Что бы получилось в итоге 321
                                                                                                                                                                      654
Прошу помощи у знатоков.
Внизу исходный макрос автора
Спасибо!
Код
Sub makeAMirror()
    Dim startRn As Range, PasteRn As Range, tmpRn  As Range
    Set startRn = [A2:V6]
    Set PasteRn = Range("A20").Cells.Resize(startRn.Rows.Count, startRn.Columns.Count)
    PasteRn.Clear
    For i = 1 To startRn.Rows.Count
        For j = 1 To startRn.Columns.Count
            With startRn.Cells(startRn.Rows.Count - i + 1, startRn.Columns.Count - j + 1)
                If .MergeCells = True And PasteRn.Cells(i, j).MergeCells = False Then
                    Set tmpRn = Range(.Offset((.MergeArea.Rows.Count - 1) * (-1), (.MergeArea.Columns.Count - 1) * (-1)), .Cells)
                    tmpRn.Copy Destination:=PasteRn.Cells(i, j)
                ElseIf PasteRn.Cells(i, j).MergeCells = False Then
                    .Copy Destination:=PasteRn.Cells(i, j)
                End If
            End With
        Next j
    Next i
End Sub
Изменено: Allspace - 13.01.2020 16:38:11
 
Allspace, здравствуйте!
Покажите (ручками) в файле-примере с листами "как есть" и "как надо"

P.S.: код оформите кнопкой <…> на панели
Изменено: Jack Famous - 13.01.2020 16:30:31
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Спасибо что откликнулись. Прикрепил файл. Это схема вязаной вещи. Правая и левая части абсолютно одинаковые. В файле правая. Очень хочется отзеркалить её, что-бы не делать опять всё руками.
 
Мдааа, докатились до вышивания крестиком :-)
По вопросам из тем форума, личку не читаю.
 
Allspace, пробуйте
Запустить на листе, который хотите «отзеркалить»
Поячеечное копирование работает долго - у меня 15 тыс. ячеек примера обрабатывались 80 секунд
UPD с учётом #13
время выполнения: 81 секунда (+1 сек в сравнении с предыдущим вариантом)
Изменено: Jack Famous - 14.01.2020 09:35:06
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Файл -Параметры -Дополнительно -Показывать лист справа налево  :D  
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
Файл > параметры > дополнительно > показывать лист справа налево.
 
Спасибо!) Дай Вам Бог здоровья и всего - чего хочется!) Всё супер!
У меня на таких объёмах комп просто зависал!
И если не секрет - Вы с помощью макроса это делали? и если да - кодом не поделитесь? На будущее...)
 
Теперь завис я)))
 
Цитата
Allspace: И если не секрет - Вы с помощью макроса это делали? и если да - кодом не поделитесь? На будущее...)
если вы мне, то код под спойлером в сообщении и внутри файла
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Jack Famous, копия то так себе. не достаточно просто скопировать , нужно еще отзеркалить контур, а иначе он сместился.
По вопросам из тем форума, личку не читаю.
 
Цитата
БМВ: копия то так себе
ТС молчит + "вылизывать" мне неохота
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
Цитата
Jack Famous написал:
"вылизывать" мне неохота
А что еще коту делать?  :D
Код
            Set sCell = rng.Cells(r, c)
            Set dCell = sh.Cells(r, cc - c + 1)
          
            sCell.Copy dCell
            With dCell
                With .Borders(xlEdgeLeft)
                    .LineStyle = sCell.Borders(xlEdgeRight).LineStyle
                    .Color = sCell.Borders(xlEdgeRight).Color
                    .Weight = sCell.Borders(xlEdgeRight).Weight
                End With
                With .Borders(xlEdgeRight)
                    .LineStyle = sCell.Borders(xlEdgeLeft).LineStyle
                    .Color = sCell.Borders(xlEdgeLeft).Color
                    .Weight = sCell.Borders(xlEdgeLeft).Weight
                End With
                
            End With
По вопросам из тем форума, личку не читаю.
 
Гы )
 
Обновил #5 с учётом варианта от БМВ из #13
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх