VBA /VB/VB中合成分散数据方法

公司用于项目号的合成，怕忘记，特此放上这里。若能帮助其它道友，善莫大焉。

比如：001,004，006,007,008,009,010

结果可以输出：001,004,006-010

逻辑：
1、获得数据（一般从表中提取）

2、定义数组，并赋值。（数组大小根据表中数据个数判断）

3、排序（这里用冒泡法，小到大）

4、综合判断数据（核心判断：从步距来判断是否连接和使用哪种符号相连，前后相距1，那么用“-”，前相距非1，用“，”）

5、根据想要的格式进行输出

 Function Br_合成项目号()

     Dim rst As New ADODB.Recordset
     rst.CursorLocation = adUseClient

     Dim Dst As New ADODB.Recordset
     Dst.CursorLocation = adUseClient
     Dst.Open "SELECT * From tb1;", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

     Dst.MoveFirst
     Do Until Dst.EOF

         rst.Open "SELECT * From tb1 where [项目号]='" & Dst.Fields("项目号") & "';", CurrentProject.Connection, adOpenKeyset, adLockOptimistic

             Dim Br_arry

             ReDim Br_arry(rst.RecordCount)

             rst.MoveFirst
             '数组初始化
             Do Until rst.EOF

                 Br_arry(rst.AbsolutePosition) = Right(rst.Fields("梯号"), )

             rst.MoveNext
             Loop

         '排序，综合==================================================

                 '冒泡排序，注意要用数字类型
                 For I =  To rst.RecordCount -
                     For K = I +  To rst.RecordCount

                         If CInt(Br_arry(I)) > CInt(Br_arry(K)) Then

                             Dim Str001%
                             Str001 = Br_arry(K)
                             Br_arry(K) = Br_arry(I)
                             Br_arry(I) = Str001

                         End If

                     Next K
                 Next I

             '根据想要的格式进行追加设置
             Dim Br_Pjt001$

             '第一个数组，注意类型转换
             Br_Pjt001 = CStr(Format(CInt(Br_arry()), ""))

             '判断是否连续
             If CInt(Br_arry(rst.RecordCount)) - CInt(Br_arry()) +  = rst.RecordCount Then '满足条件为连续数字
                 Br_Pjt001 = Format(CInt(Br_arry()), "") & "-" & Format(CInt(Br_arry(rst.RecordCount)), "")

             Else

                 For I =  To rst.RecordCount - 

                     If Br_arry(I + ) - Br_arry(I) =  Then  '数字连续段 与后面相距1个单位

                         If I =  Then
                         Else

                             If Len(Br_Pjt001) >  Then '长度超过4才进行处理，一开始情况
                                 If Br_arry(I) - Br_arry(I - ) =  Then '前后都相距1个单位，才进行裁剪

                                     Br_Pjt001 = Mid(Br_Pjt001, , Len(Br_Pjt001) - )

                                 End If
                             End If

                             Br_Pjt001 = Br_Pjt001 & "-" & Format(Br_arry(I + ), "")
                         End If

                     Else

                         Br_Pjt001 = Br_Pjt001 & "," & Format(Br_arry(I + ), "")

                     End If

                 Next I

             End If

         '排序，综合==================================================

         Debug.Print Dst.Fields("项目号") & "." & Br_Pjt001

         Dst.Fields("EEE") = Dst.Fields("项目号") & "." & Br_Pjt001

         rst.Close

     Dst.MoveNext
     Loop

 End Function