' Excel VBA Code SortThisRangeAndOutputItsResultToANewSheet

'

' Excel VBA Code SortThisRangeAndOutputItsResultToANewSheet

'

Public Sub SortThisRangeAndOutputItsResultToANewSheet()
' (本段程式之目的) Purpose:
'     Sort this range and output its result to a new sheet.
' (本段程式是否已經在被使用中) In use: Yes
' (重要等級) Importance rating:  80%
' (再利用的可能性) Chances of reuse:  80%
' (程式撰寫的進度) Developing: 100% (Mandatory)
' (程式堪用的程度) Workable: 80% (Threshold at 80%)
' (程式的測試程度) Code tested: 80% (max 99%)
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' (修改程式的日期) Revision Date: (2005 12 22 PM 08 39 55)
' (修改程式的人員) Revised by: WeiJin Tang (湯偉晉)
'     OK
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

    Dim R1 As Excel.Range
    Dim R2 As Excel.Range
   
    Set R1 = Selection.CurrentRegion
   
    ' insert 2 new columns to my right
    R1.Columns("B:C").Select
    Selection.Insert Shift:=xlToRight
    Selection.Interior.ColorIndex = xlNone
   
    ' Copy ... and paste it to my right hand side
    R1.Copy
    R1.Cells(1, 3).Select
    ActiveSheet.Paste
   
    ' Cancel CutCopy mode
    Application.CutCopyMode = False

    ' Select the range to be sorted
    Set R2 = ActiveCell.CurrentRegion
   
    ' Sort this range using first column as the sorting key
    R2.Sort Key1:=R2.Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
        :=xlStroke, DataOption1:=xlSortNormal
   
    R2.Interior.ColorIndex = 4

End Sub ' SortThisRangeAndOutputItsResultToANewSheet
' -   -   -   -   -   -   -   -   -   -   -   -   -
' -   -   -   -   -   -   -   -   -   -   -   -   -