Sub SwapRanges()
Dim ra As Range: Set ra = Selection
msg1 = "Надо выделить ДВА диапазона ячеек одинакового размера"
msg2 = "Надо выделить 2 диапазона ячеек ОДИНАКОВОГО размера"
If ra.Areas.Count <> 2 Then MsgBox msg1, vbCritical, "Ошибка": Exit Sub
If ra.Areas(1).Count <> ra.Areas(2).Count Then MsgBox msg2, vbCritical, "Ошибка": Exit Sub
Application.ScreenUpdating = False
arr2 = ra.Areas(2).Value
ra.Areas(2).Value = ra.Areas(1).Value
ra.Areas(1).Value = arr2
End Sub

Sub Inic()
With Application.CommandBars("Cell").Controls.Add(Type:=msoControlButton, before:=1)
            .Caption = "SwapRanges"
            .OnAction = "SwapRanges"
            .FaceId = 203
End With
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
           Application.CommandBars("Cell").Controls.Item("SwapRanges").Delete
End Sub

Private Sub Workbook_Open()
On Error Resume Next
           Application.CommandBars("Cell").Controls.Item("SwapRanges").Delete
           On Error GoTo 0
Inic
End Sub

Sub Selection_eXchange()
'---------------------------------------------------------------------------------------
' Procedure    : Selection_eXchange
' Author       : Alex_ST
' Topic_HEADER : Поменять указанные столбцы местами с помощью макроса
' Topic_URL    : http://www.planetaexcel.ru/forum.php?thread_id=15210
' Post_Author  : Alex_ST
' Post_URL     : http://www.planetaexcel.ru/forum.php?thread_id=15210
' DateTime     : 13.04.10, 16:33
' Purpose      : обменять ТЕКСТ двух выделенных диапазонов или областей
' Notes        :
'---------------------------------------------------------------------------------------
      If Not TypeName(Selection) = "Range" Then Exit Sub
      Dim tmpVar1, tmpVar2
      Dim tmpRng1 As Range, tmpRng2 As Range
      With Selection
          'With Intersect(Selection, Selection.Parent.UsedRange)
          Select Case .Areas.Count
          Case 1   ' выделена 1 область
              If .Count = 2 Then   ' выделено 2 ячейки
                  Set tmpRng1 = .Cells(1): Set tmpRng2 = .Cells(2)
              ElseIf .Rows.Count = 2 And .Columns.Count > 2 Then  ' выделен горизонтальный диапазон в 2 строки
                  Set tmpRng1 = Range(Cells(.Row, .Column), Cells(.Row, .Column + .Columns.Count - 1))   ' 1-я строка диапазона
                  Set tmpRng2 = tmpRng1.Offset(1, 0)   ' 2-я строка ниже на 1
              ElseIf .Columns.Count = 2 And .Rows.Count > 2 Then    ' выделен вертикальный диапазон в 2 столбца
                  Set tmpRng1 = Range(Cells(.Row, .Column), Cells(.Row + .Rows.Count - 1, .Column))  ' 1-й столбец
                  Set tmpRng2 = tmpRng1.Offset(0, 1)   ' 2-й столбец правее на 1
              Else: Exit Sub
              End If
          Case 2   ' выделено 2 области
              If .Areas(1).Columns.Count = .Areas(2).Columns.Count And _
                 .Areas(1).Rows.Count = .Areas(2).Rows.Count Then   ' одинаковая размерность областей
                  Set tmpRng1 = .Areas(1): Set tmpRng2 = .Areas(2)
              End If
          Case Else: Exit Sub
          End Select
      End With
      Application.ScreenUpdating = False: Application.EnableEvents = False
      tmpVar1 = tmpRng1: tmpVar2 = tmpRng2
      tmpRng1.Value = tmpVar2: tmpRng2.Value = tmpVar1
      Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
       On Error Resume Next
       Application.CommandBars("Cell").Controls.Item("SwapRanges").Delete
End Sub

Private Sub Workbook_Open()
       On Error Resume Next
       With Application.CommandBars("Cell").Controls
           .Item("SwapRanges").Delete
           With .Add(Type:=msoControlButton, before:=1)
               .Caption = "SwapRanges"
               .OnAction = "SwapRanges"
               .FaceId = 203
           End With
       End With
       On Error GoTo 0
End Sub