Добрый день. На старой ветке форума нашёл макрос автора 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
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Спасибо что откликнулись. Прикрепил файл. Это схема вязаной вещи. Правая и левая части абсолютно одинаковые. В файле правая. Очень хочется отзеркалить её, что-бы не делать опять всё руками.
Option Explicit
'===========================================================================================
Sub Mirror()
Dim sh As Worksheet, rng As Range
Dim r&, c&, cc&, AC&, t!
t = Timer
Application.ScreenUpdating = False
AC = Application.Calculation
Application.Calculation = xlCalculationManual
Set rng = ActiveSheet.UsedRange
Worksheets.Add
Set sh = ActiveSheet
cc = rng.Columns.Count
For r = 1 To rng.Rows.Count
For c = 1 To cc
rng.Cells(r, c).Copy sh.Cells(r, cc - c + 1)
Next c
Next r
Application.Calculation = AC
Application.ScreenUpdating = True
MsgBox "Ячеек обработано: " & rng.Count, vbInformation, Format$(Timer - t, "0 сек")
End Sub
'===========================================================================================
Поячеечное копирование работает долго - у меня 15 тыс. ячеек примера обрабатывались 80 секунд
UPD с учётом #13
Код
Option Explicit
'===========================================================================================
Sub Mirror()
Dim sh As Worksheet, rng As Range, clOld As Range, clNew As Range
Dim r&, c&, cc&, AC&, t!
t = Timer
Application.ScreenUpdating = False
AC = Application.Calculation
Application.Calculation = xlCalculationManual
Set rng = ActiveSheet.UsedRange
Worksheets.Add
Set sh = ActiveSheet
cc = rng.Columns.Count
For r = 1 To rng.Rows.Count
For c = 1 To cc
Set clOld = rng.Cells(r, c)
Set clNew = sh.Cells(r, cc - c + 1)
clOld.Copy clNew
With clNew
With .Borders(xlEdgeLeft)
.LineStyle = clOld.Borders(xlEdgeRight).LineStyle
.Color = clOld.Borders(xlEdgeRight).Color
.Weight = clOld.Borders(xlEdgeRight).Weight
End With
With .Borders(xlEdgeRight)
.LineStyle = clOld.Borders(xlEdgeLeft).LineStyle
.Color = clOld.Borders(xlEdgeLeft).Color
.Weight = clOld.Borders(xlEdgeLeft).Weight
End With
End With
Next c
Next r
Application.Calculation = AC
Application.ScreenUpdating = True
MsgBox "Ячеек обработано: " & rng.Count, vbInformation, Format$(Timer - t, "0 сек")
End Sub
'===========================================================================================
время выполнения: 81 секунда (+1 сек в сравнении с предыдущим вариантом)
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Спасибо!) Дай Вам Бог здоровья и всего - чего хочется!) Всё супер! У меня на таких объёмах комп просто зависал! И если не секрет - Вы с помощью макроса это делали? и если да - кодом не поделитесь? На будущее...)
Allspace: И если не секрет - Вы с помощью макроса это делали? и если да - кодом не поделитесь? На будущее...)
если вы мне, то код под спойлером в сообщении и внутри файла
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
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
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄