文章背景：在数据处理时，有时需要根据指定列的内容进行重新排序。比如样品测试时，假设存在5个测试点，其中2号点和3号点无需测，在做报告时，一般会保留2号点和3号点的位置，测试数据为空。
针对排序的步骤，可以通过VBA代码实现。之前提到过两种方法，参见文末的延伸阅读。当数据条不多时，这两种方法的运行时长还可以接受。当数据条有上百条时，运行耗时相对较长。下面借助字典和数组，介绍第三种排序的方法。
代码实现：在原有测试数据的基础上，根据“品号”列和给定的测试点数目（暂定91个），进行重新排序。
代码语言：javascript复制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运行效果：http://mpvideo.qpic.cn/0b2eriaagaaapmao7uianvrvbcwdaofaaaya.f10002.mp4?dis_k=c9a360481cd2c7e3e4bfeac3cde0db00&dis_t=1671335557&play_scene=0&vid=wxv_2540284762230505472&format_id=10002&support_redirect=0&mmversion=false
