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

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

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

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

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

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

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

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

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

  1 Function Br_合成项目号()
  2 
  3     Dim rst As New ADODB.Recordset
  4     rst.CursorLocation = adUseClient
  5 
  6    
  7     
  8     
  9     Dim Dst As New ADODB.Recordset
 10     Dst.CursorLocation = adUseClient
 11     Dst.Open "SELECT * From tb1;", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
 12     
 13     
 14     
 15     
 16     Dst.MoveFirst
 17     Do Until Dst.EOF
 18         
 19 
 20         
 21         rst.Open "SELECT * From tb1 where [项目号]='" & Dst.Fields("项目号") & "';", CurrentProject.Connection, adOpenKeyset, adLockOptimistic
 22         
 23             Dim Br_arry
 24 
 25             ReDim Br_arry(rst.RecordCount)
 26             
 27             rst.MoveFirst
 28             '数组初始化
 29             Do Until rst.EOF
 30         
 31                 Br_arry(rst.AbsolutePosition) = Right(rst.Fields("梯号"), 3)
 32             
 33             rst.MoveNext
 34             Loop
 35 
 36         
 37      
 38         
 39         
 40         
 41         '排序，综合==================================================
 42                     
 43             
 44             
 45                 '冒泡排序，注意要用数字类型
 46                 For I = 1 To rst.RecordCount - 1
 47                     For K = I + 1 To rst.RecordCount
 48                     
 49                         If CInt(Br_arry(I)) > CInt(Br_arry(K)) Then
 50             
 51                             Dim Str001%
 52                             Str001 = Br_arry(K)
 53                             Br_arry(K) = Br_arry(I)
 54                             Br_arry(I) = Str001
 55                             
 56                         End If
 57                         
 58                     Next K
 59                 Next I
 60                 
 61                
 62                
 63             '根据想要的格式进行追加设置
 64             Dim Br_Pjt001$
 65             
 66             '第一个数组，注意类型转换
 67             Br_Pjt001 = CStr(Format(CInt(Br_arry(1)), "000"))
 68             
 69             '判断是否连续
 70             If CInt(Br_arry(rst.RecordCount)) - CInt(Br_arry(1)) + 1 = rst.RecordCount Then '满足条件为连续数字
 71                 Br_Pjt001 = Format(CInt(Br_arry(1)), "000") & "-" & Format(CInt(Br_arry(rst.RecordCount)), "000")
 72             
 73             Else
 74                 
 75                 For I = 1 To rst.RecordCount - 1
 76                 
 77                     If Br_arry(I + 1) - Br_arry(I) = 1 Then  '数字连续段 与后面相距1个单位
 78                     
 79                         If I = 1 Then
 80                         Else
 81                             
 82                             If Len(Br_Pjt001) > 4 Then '长度超过4才进行处理，一开始情况
 83                                 If Br_arry(I) - Br_arry(I - 1) = 1 Then '前后都相距1个单位，才进行裁剪
 84                                 
 85                                     Br_Pjt001 = Mid(Br_Pjt001, 1, Len(Br_Pjt001) - 4)
 86                                     
 87                                 End If
 88                             End If
 89                             
 90                             Br_Pjt001 = Br_Pjt001 & "-" & Format(Br_arry(I + 1), "000")
 91                         End If
 92                         
 93                     Else
 94                             
 95                         Br_Pjt001 = Br_Pjt001 & "," & Format(Br_arry(I + 1), "000")
 96                         
 97                     End If
 98                     
 99                 
100                 Next I
101                 
102                 
103             End If
104             
105 
106         '排序，综合==================================================
107         
108         
109         
110         
111         Debug.Print Dst.Fields("项目号") & "." & Br_Pjt001
112         
113         
114         Dst.Fields("EEE") = Dst.Fields("项目号") & "." & Br_Pjt001
115         
116         
117         
118         rst.Close
119         
120     
121     Dst.MoveNext
122     Loop
123 
124 
125 
126 
127 
128 End Function

View Code

 

转载于:https://www.cnblogs.com/brucebear/p/6742723.html