Clasificación de dos columnas no adyacentes sin afectar a ninguna otra columna

Tengo dos columnas diferentes en Excel. Quiero crear una secuencia de comandos que ordene la Columna F, (Tener un encabezado) y la Columna B según la clasificación de la Columna F. (¡Sin afectar a ninguna otra columna sin embargo!)

Así que si tengo

    ColB       ColF
 1. Cat        2
 2. Mouse      1
 3. Dog        3

El tipo me dará

    ColB       ColF
 1. Mouse        1
 2. Cat          2
 3. Dog          3

¿Cómo puedo hacer esto? Intenté grabar una macro, (o simplemente intentando ordenarla con las dos columnas pulsadas y el botón de ordenación), pero aparece un mensaje de error. "El comando no se puede realizar con selecciones múltiples, haga clic en un solo rango e intente nuevamente"

Sospecho que debe haber una mejor manera de lograr lo que sea que desee hacer al ordenar estas columnas, pero aquí hay una solución VBA que hará exactamente lo que pidió. Tenga en cuenta que este código asume que no hay celdas en blanco en los rangos que desea ordenar. Por favor, deje un comentario si esto es un problema, porque será bastante fácil de solucionar.

Sub nonadjacentsort()
Dim rng1 As Range, rng2 As Range, rngTmp As Range, s1 As Worksheet, tmpS As Worksheet
Dim tmpArr1() As Variant, tmpArr2() As Variant
Dim i As Long
Set s1 = ActiveSheet
'Set Ranges to sort.  This assumes there are no blanks in your data.
Set rng1 = s1.Range("B1", Range("B1").End(xlDown))
Set rng2 = s1.Range("F1", Range("F1").End(xlDown))
'Load first column into temporary array
tmpArr1 = rng1.Value
'Load data into larger array that will hold both columns
ReDim tmpArr2(1 To UBound(tmpArr1, 1), 1 To 2) As Variant
For i = 1 To UBound(tmpArr1, 1)
    tmpArr2(i, 1) = tmpArr1(i, 1)
Next i
'Load second column into temporary array
Erase tmpArr1
tmpArr1 = rng2.Value
'Load second column into larger array
For i = 1 To UBound(tmpArr1, 1)
    tmpArr2(i, 2) = tmpArr1(i, 1)
Next i
Erase tmpArr1
'Add new sheet and print two columns there together.
Application.ScreenUpdating = False
Set tmpS = Sheets.Add
Set rngTmp = tmpS.Range("A1").Resize(UBound(tmpArr2, 1), 2)
rngTmp = tmpArr2
Erase tmpArr2
'Sort by second column (Column F of original data)
rngTmp.Sort rngTmp.Cells(1, 2), xlAscending, Header:=xlYes
'Load sorted data into array and then overwrite columns on original data
tmpArr1 = rngTmp.Columns(1).Value
rng1 = tmpArr1
Erase tmpArr1
tmpArr1 = rngTmp.Columns(2).Value
rng2 = tmpArr1
Erase tmpArr1
'Delete temporary sheet.
Application.DisplayAlerts = False
tmpS.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub