View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
minimaster minimaster is offline
external usenet poster
 
Posts: 73
Default Swap part of 2 columns

This is a general routine which will swap to selected areas, means you
have to select the two columns seperately. Press the ctrl button when
selecting the 2nd area to retain the selection of the first area.

Sub swap_areas()
Dim buf As Variant
Dim i As Long
Dim xlong As Long
Dim areaSwap1 As Range, areaSwap2 As Range, onepast2 As Range
If Not ActiveWorkbook Is Nothing Then

If Selection.Areas.Count < 2 Then
If Selection.Cells.Count = 2 Then
' simple swap of two cells in one area
buf = Selection.Cells(1)
Selection.Cells(1) = Selection.Cells(2)
Selection.Cells(2) = buf
Else
MsgBox "Must have exactly two areas or two cells for
swap." & Chr(10) _
& "You have " & Selection.Areas.Count & "
areas."
Exit Sub
End If
Else
If Selection.Areas(1).Rows.Count = Range
("A1").EntireColumn.Rows.Count Then
' we have complete columns for swapping
' David McRitchie, 2004-01-05, http://www.mvps.org/dmcritchie/swap.htm
' and mods by me 2007-01-17
'--verify that Area 2 columns follow area 1 columns
'--so that adjacent single column swap will work.
If Selection.Areas(1)(1).Column Selection.Areas(2)
(1).Column Then
Range(Selection.Areas(2).Address & "," &
Selection.Areas(1).Address).Select
Selection.Areas(2).Activate
End If
Set areaSwap1 = Selection.Areas(1)
Set areaSwap2 = Selection.Areas(2)
Set onepast2 = areaSwap2.Offset(0,
areaSwap2.Columns.Count).EntireColumn
areaSwap2.Cut
areaSwap1.Resize(, 1).EntireColumn.Insert
Shift:=xlShiftToRight
areaSwap1.Cut
onepast2.Resize(, 1).EntireColumn.Insert
Shift:=xlShiftToRight
Range(areaSwap1.Address & "," &
areaSwap2.Address).Select
xlong = ActiveSheet.UsedRange.Rows.Count 'correct
lastcell
ElseIf Selection.Areas(1).Columns.Count = Range
("A1").EntireRow.Columns.Count Then
' we have complete rows to swap
' David McRitchie, 2004-01-05, http://www.mvps.org/dmcritchie/swap.htm
' with some modification by me 2007-01-17
'--verify that Area 2 rows follow area 1 rows
If Selection.Areas(1)(1).Row Selection.Areas(2)
(1).Row Then
Range(Selection.Areas(2).Address & "," &
Selection.Areas(1).Address).Select
Selection.Areas(2).Activate
End If
Set areaSwap1 = Selection.Areas(1)
Set areaSwap2 = Selection.Areas(2)
Set onepast2 = areaSwap2.Offset(areaSwap2.Rows.Count,
0).EntireRow
areaSwap2.Cut
areaSwap1.Resize(1).EntireRow.Insert
Shift:=xlShiftDown
areaSwap1.Cut
onepast2.Resize(1).EntireRow.Insert Shift:=xlShiftDown
Range(areaSwap1.Address & "," &
areaSwap2.Address).Select
xlong = ActiveSheet.UsedRange.Columns.Count 'correct
lastcell
ElseIf Selection.Areas(1).Cells.Count = Selection.Areas
(2).Cells.Count Then
' swap 2 areas
All_off ' just in case its two very large areas
For i = 1 To Selection.Areas(1).Cells.Count
Application.StatusBar = Selection.Areas(1).Cells
(i).Address(RowAbsolute:=False, ColumnAbsolute:=False)
buf = Selection.Areas(1).Cells(i)
Selection.Areas(1).Cells(i) = Selection.Areas
(2).Cells(i)
Selection.Areas(2).Cells(i) = buf
Next i
All_on
Else
MsgBox "The two areas have different number of cells!"
& Chr(10) & _
"The two selected areas must have identical
number of cells," & Chr(10) & _
"or two areas with entire rows or columns must
be selected."
End If
End If
End If
End Sub

Sub All_on()
With Application
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlAutomatic
.ScreenUpdating = True
.StatusBar = False
'Toolbars("VBA_tools").ToolbarButtons(1).Name = "Auto
Calculate Off"
End With
End Sub
Sub All_off()
With Application
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlManual
.ScreenUpdating = False
'Toolbars("VBA_tools").ToolbarButtons(1).Name = "Auto
Calculate On"
End With
End Sub