Windows 7 - Need to swap some data in Excel

'July 07, 2006 - James Cone - San Francisco, USA 
On Error GoTo SwapError 
Dim rngSelect As Excel.Range 
Dim rngOne As Excel.Range 
Dim rngTwo As Excel.Range 
Dim lngNum As Long 
Dim strGeneric As String 
Dim varValueOne As Variant 
Set rngSelect = Excel.Selection 
'If entire columns or rows selected, don't use, resize to used range boundries. 
If rngSelect.Rows.Count = ActiveSheet.Rows.Count Then 
Set rngSelect = Application.Intersect(rngSelect, ActiveSheet.UsedRange.EntireRow) 
ElseIf rngSelect.Columns.Count = ActiveSheet.Columns.Count Then 
Set rngSelect = Application.Intersect(rngSelect, ActiveSheet.UsedRange.EntireColumn) 
End If 
'Check for merged cells and the number of areas/cells selected. 
If rngSelect.MergeCells Or IsNull(rngSelect.MergeCells) Then 
strGeneric = "Unmerge cells in the selection and try again. " 
ElseIf rngSelect.Areas.Count > 2 Then 
strGeneric = "Can only swap two selections." & vbCr & _ 
"There are " & rngSelect.Areas.Count & " selections on the worksheet. " 
ElseIf rngSelect.Areas.Count = 1 Then 
If rngSelect.Columns.Count = 2 Then 
Set rngOne = rngSelect.Columns(1).Cells 
Set rngTwo = rngSelect.Columns(2).Cells 
ElseIf rngSelect.Rows.Count = 2 Then 
Set rngOne = rngSelect.Rows(1).Cells 
Set rngTwo = rngSelect.Rows(2).Cells 
ElseIf rngSelect.Count <> 2 Then 
strGeneric = " Two selections are necessary. " 
ElseIf Application.CountA(rngSelect) = 0 Then 
strGeneric = "The selection is blank. " 
Else 
Set rngOne = rngSelect(1) 
Set rngTwo = rngSelect(2) 
End If 
Else 'Two areas 
Set rngOne = rngSelect.Areas(1) 
Set rngTwo = rngSelect.Areas(2) 
If rngOne.Rows.Count <> rngTwo.Rows.Count Or _ 
rngOne.Columns.Count <> rngTwo.Columns.Count Then 
strGeneric = "The two selections must be the same size. " 
ElseIf Application.CountA(rngOne) + Application.CountA(rngTwo) = 0 Then 
strGeneric = "Both selections are blank. " 
End If 
End If 
If Len(strGeneric) Then 
MsgBox strGeneric, vbInformation, " Swap Cells" 
GoTo CleanUp 
ElseIf rngOne.Address = rngTwo.Address Then 
GoTo CleanUp 
End If 
'With multiple cells Apply formats and formulas to each cell. 
If rngOne.Count > 1 Then 
Application.ScreenUpdating = False 
For lngNum = 1 To rngOne.Count 
Set rngSelect = rngOne(lngNum) 
With rngSelect 
strGeneric = .NumberFormat 
varValueOne = .Formula 
.NumberFormat = rngTwo(lngNum).NumberFormat 
.Formula = rngTwo(lngNum).Formula 
End With 
rngTwo(lngNum).NumberFormat = strGeneric 
rngTwo(lngNum).Formula = varValueOne 
Next 
Application.ScreenUpdating = True 
Else 'One cell vs. one cell 
strGeneric = rngOne.NumberFormat 
varValueOne = rngOne.Formula 
rngOne.NumberFormat = rngTwo.NumberFormat 
rngOne.Formula = rngTwo.Formula 
rngTwo.NumberFormat = strGeneric 
rngTwo.Formula = varValueOne 
End If 
CleanUp: 
On Error Resume Next 
Set rngSelect = Nothing 
Set rngOne = Nothing 
Set rngTwo = Nothing 
Exit Sub 
SwapError: 
Application.ScreenUpdating = True 
MsgBox "Error " & Err.Number & " - " & Err.Description & " ", vbCritical, " Swap Cells" 
GoTo CleanUp 
End Sub