■選択範囲を180度回転させて新規シートにコピーする
'------------------------------------------------
'選択範囲を180度回転させて新規シートにコピーする
'
' 選択範囲の最終セルを貼付け先の最初のセルへ、
' 最後から2番目のセルを貼付け先の2番目のセルへ、
' これを繰り返していく
' (注)セルの結合は解除される
'------------------------------------------------
Sub rotate()
Dim tArea As Range
Dim pos As Long
Dim r As Long
Dim c As Long
Dim i As Long
Dim before As Variant
Dim after As Variant
'罫線処理用
before = Array(xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlEdgeLeft)
after = Array(xlEdgeBottom, xlEdgeTop, xlEdgeLeft, xlEdgeRight)
'選択範囲
Set tArea = Selection
'選択範囲の最終セル番号
pos = Selection.Cells.Count
Application.ScreenUpdating = False
'新規シート追加
Worksheets.Add after:=Worksheets(Worksheets.Count)
For r = 1 To tArea.Rows.Count
For c = 1 To tArea.Columns.Count
'(注)行と列を+1しているのは、上と左の罫線が見えるようにコピー先をB2にするため
tArea.Cells(pos).Copy Destination:=Worksheets(Worksheets.Count).Cells(r + 1, c + 1)
'罫線の処理
With Worksheets(Worksheets.Count).Cells(r + 1, c + 1)
'一旦罫線をクリア
.Borders.LineStyle = xlNone
'セルの上下左右を走査
For i = 0 To 3
If tArea.Cells(pos).Borders(before(i)).LineStyle <> xlNone Then
'罫線を対辺に引く
.Borders(after(i)).LineStyle = tArea.Cells(pos).Borders(before(i)).LineStyle
'太さと色を設定
.Borders(after(i)).Weight = tArea.Cells(pos).Borders(before(i)).Weight
.Borders(after(i)).Color = tArea.Cells(pos).Borders(before(i)).Color
End If
Next
End With
'1つ前のセルへ移動
pos = pos - 1
Next
Next
'セルの高さと幅を変更
For r = 1 To tArea.Rows.Count
Worksheets(Worksheets.Count).Cells(r + 1, 1).RowHeight = tArea.Rows(r).RowHeight
Next
For c = 1 To tArea.Columns.Count
Worksheets(Worksheets.Count).Cells(1, c + 1).ColumnWidth = tArea.Columns(c).ColumnWidth
Next
Application.ScreenUpdating = True
End Sub
