Swap part of 2 columns

Q

QB

I would like to select a range comprising 2 columns (ie: a13:B34) and click a
button and it would swap the values (ie: a13 would become b13 and b13 would
become a13 for row 13 through 34. How would I code such a feat?

Thank you,

QB
 
M

minimaster

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
 
M

minimaster

This is a general routine which will swap two 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
End With
End Sub
Sub All_off()
With Application
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlManual
.ScreenUpdating = False
End With
End Sub
 
C

Chip Pearson

Select the data in the first column (or both, it doesn't matter), and
run the following code.

Sub Swap()
Dim R As Range
Dim V As Variant
For Each R In Selection.Columns(1).Cells
V = R(1, 1).Value2
R(1, 1).Value = R(1, 2).Value2
R(1, 2).Value = V
Next R
End Sub

This assumes that the selection has one area, no formulas, no merged
cells, etc, just values. Data is swapped but formatting is not.

Cordially,
Chip Pearson
Microsoft MVP 1998 - 2010
Pearson Software Consulting, LLC
www.cpearson.com
[email on web site]
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Copy down 1 column to the left 3
Run time error Method 'Range' of Object '_Worksheet' Failed 5
Adding a row with the previous one if.... 1
MS Excel VBA Worksheets group tables in one table. 1
MsgBox with information on selected cells 11
Auto-Numbering fails 0
Finding the proper style field and the numbered paragraph value within the style 0
Macro Help 3

Top