VBA: 单元格区域基于指定列重新排序（4）

Option Explicit

Sub SampleNo_Reordering()

    '基于单号，重新排序
    
    Dim row_final As Integer
    
    Dim tarSheet As Worksheet
    
    Set tarSheet = ThisWorkbook.Worksheets("test")

    tarSheet.Activate
    
    row_final = tarSheet.Range("A65535").End(xlUp).Row
    
    Application.Calculation = xlCalculationAutomatic   'Formula自动计算

    '添加三个辅助列
    Columns("B:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
    Columns("B:D").NumberFormatLocal = "G/通用格式"
    
    '字母
    Range("B2").FormulaR1C1 = "=GetLetters(RC[-1])"
    
    Range("B2").AutoFill Destination:=Range("B2:B" & row_final)
    
    '数字
    Range("C2").FormulaR1C1 = "=GetNumbers(RC[-2])"

    Range("C2").AutoFill Destination:=Range("C2:C" & row_final)
    
    '字母个数
    Range("D2").FormulaR1C1 = "=LEN(RC[-2])"

    Range("D2").AutoFill Destination:=Range("D2:D" & row_final)
    
    '设定筛选条件
    With tarSheet.Sort.SortFields
        .Clear
        .Add2 Key:=Range("D2:D" & row_final) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add2 Key:=Range("B2:B" & row_final) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Add2 Key:=Range("C2:C" & row_final) _
            , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    End With

    ' 排序
    With tarSheet.Sort
    
        .SetRange Rows("2:" & row_final)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
        
    End With

    '删除辅助列
    Range("B:D").Delete Shift:=xlToLeft
    
    MsgBox "Done!"

    Exit Sub

End Sub

Function GetLetters(ByVal str As String) As String

    '提取单号末尾的字母
    
    '如BYD24-0001001-AA1, 提取AA
    
    Dim regEx As Object, matches As Object
    
    Set regEx = CreateObject("VBScript.RegExp")
    
    With regEx
    
        .Global = True
        
        .IgnoreCase = False
        
        .Pattern = "-([A-Za-z]+)\d+$"
        
    End With
    
    Set matches = regEx.Execute(str)
    
    If matches.Count > 0 Then
    
        GetLetters = matches(0).SubMatches(0)
        
    Else
    
        GetLetters = "A"        '默认值为A
        
    End If
    
End Function

Function GetNumbers(ByVal str As String) As String

    '提取单号末尾的数字
    
    '如BYD24-0001001-AA3, 提取3

    Dim regEx As Object, matches As Object
    
    Set regEx = CreateObject("VBScript.RegExp")
    
    With regEx
    
        .Global = True
        
        .IgnoreCase = False
        
        .Pattern = "-[A-Za-z]+(\d+)$"
        
    End With
    
    Set matches = regEx.Execute(str)
    
    If matches.Count > 0 Then
    
        GetNumbers = Format(matches(0).SubMatches(0), "0000")
        
    Else
    
        GetNumbers = "0001"     '默认值为0001
        
    End If
    
End Function