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

Exploring

发布于 2024-04-22 11:01:17

1140

发布于 2024-04-22 11:01:17

文章被收录于专栏：数据处理与编程实践数据处理与编程实践

文章背景： 在数据处理时，有时需要根据指定列的内容进行重新排序。

针对品号这一列，希望借助字符串末尾的序号，

（1）先按字母的个数升序，一个字母的在前，两个字母的在后；

（2）当字母个数相同时，按字母升序；

（3）当字母相同时，按数字大小升序。

数据源如下：

解决思路：

借助正则表达式，分别提取字符串末尾的字母和数字，然后通过三个辅助列（字母，数字，字母个数）进行排序。排序结束后，删除这三个辅助列。

VBA代码如下：

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

在上述代码中，程序临时添加三个辅助列（B:D列），借助这三个辅助列进行排序。排序结束后，将这三个辅助列删去。