VBA: 单元格区域基于指定列重新排序(3)

Sub sample_sort3()

    '根据品号列重新排序
    
    Dim row_ini As Integer, lastRow As Integer, number As Integer
    Dim name_sample As String, ii As Integer
    Dim sample_temp As String, row_temp As Integer, number_temp As Integer
    Dim obj_range As Range, firstAddress As String
    
    Dim time_ini As Date    '用于计时
    
    Dim col_total As Integer, dic As Object, dic_sample As Object
    
    Dim arrIn As Variant, arrOut As Variant, arrSample As Variant
    
    time_ini = Timer    '计时开始
    
    row_ini = 2     '测试数据从第2行开始 (第1行是标题行)
    
    lastRow = Cells(Rows.Count, 3).End(xlUp).Row   '测试数据最后一行的行号
    
    number = 91  '测试点数目，包括无需测的测试点。
    
    name_sample = "SAM21-123"  '样品名称
    
    col_total = 5       '数据的列数
    
    '字典初始化
    Set dic_sample = CreateObject("scripting.dictionary")      '用于存放序号
    Set dic = CreateObject("scripting.dictionary")             '用于判断点号是否已测
    
    ReDim arrOut(1 To number, 1 To col_total)
    
    ReDim arrSample(1 To number, 1 To 1)
    
    '字典序号
    For ii = 1 To number
    
        sample_temp = name_sample & "-" & CStr(ii)
        
        '使用字典储存样品点的顺序号
        dic_sample(sample_temp) = ii
        
        '使用数组存储样品点
        arrSample(ii, 1) = sample_temp
    
    Next ii
    
    '将测试数据拷贝到临时数组，减少VBA与表格的交互
    With ActiveSheet
    
        arrIn = .Range(.Cells(1, 1), .Cells(lastRow, 6)).Value2
        
    End With
    
    With ActiveSheet.Columns(3)
    
        Set obj_range = .Find(What:=name_sample, After:=Cells(2, 3), LookIn:=xlFormulas, _
                        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, MatchByte:=False, SearchFormat:=False)
                    
        If Not obj_range Is Nothing Then
    
            firstAddress = obj_range.Address
            
            Do
                sample_temp = obj_range.Value2
                
                row_temp = obj_range.Row
                
                number_temp = dic_sample(sample_temp)   '顺序号
                
                For ii = 2 To 6
                    
                    arrOut(number_temp, ii - 1) = arrIn(row_temp, ii)
                
                Next ii
                
                '记录已测的点号
                dic(sample_temp) = True
                      
                Set obj_range = .FindNext(obj_range)
                
            Loop While Not obj_range Is Nothing And obj_range.Address <> firstAddress
    
        End If
    
    End With
    
    '将数组拷贝到指定区域
    If dic.Count > 0 Then
    
        '清空旧区域
        Range("B2:F" & lastRow).ClearContents
        
        Range("B2").Resize(number, col_total) = arrOut
        
        Range("C2").Resize(number, 1) = arrSample
    
    End If
    
    MsgBox "Done!  " & vbCrLf & vbCrLf & "用时：" & Format(Timer - time_ini, "0.0s")

    Exit Sub

End Sub