数据转换问题 - Office中国论坛/Access中国论坛

Private Sub Command0_Click()
Dim rs As New ADODB.Recordset
Dim Rst As New ADODB.Recordset
Dim sSQL As String
Dim strSQL As String
Dim Arr() As Long
Dim Str As String, strLast As String
Dim I As Long, J As Long
Dim B As Boolean
sSQL = "SELECT DISTINCT ??? FROM SN ORDER BY ???"
Rst.Open sSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
Do While Not Rst.EOF
I = 0
B = True
strSQL = "SELECT ??? FROM SN WHERE ???='" & Rst.Fields(0) & "'"
rs.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
ReDim Arr(rs.RecordCount) As Long
For J = 0 To rs.RecordCount - 1
Arr(J) = rs.Fields(0)
rs.MoveNext
Next
rs.MoveFirst
Do While Not rs.EOF
I = I + 1
If Arr(I) - rs.Fields(0) = 1 Then
If B Then
Str = Str & rs.Fields(0) & "-"
B = False
End If
Else
Str = Str & Arr(I - 1) & ","
B = True
End If
rs.MoveNext
Loop
rs.Close
If Len(Str) > 0 Then
Str = Left(Str, Len(Str) - 1)
End If
strLast = strLast & Rst.Fields(0) & "(" & Str & ")??"
Str = ""
Rst.MoveNext
Loop
Me.Text4 = strLast
Rst.Close
Set rs = Nothing
Set Rst = Nothing
End Sub

复制代码

Private Sub Command0_Click()
Dim rs As New ADODB.Recordset
Dim Rst As New ADODB.Recordset
Dim sSQL As String
Dim strSQL As String
Dim Arr() As Long
Dim Str As String, strLast As String
Dim I As Long, J As Long
Dim B As Boolean
sSQL = "SELECT DISTINCT 型号 FROM SN ORDER BY 型号"
Rst.Open sSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
Do While Not Rst.EOF
I = 0
B = True
strSQL = "SELECT 序号 FROM SN WHERE 型号='" & Rst.Fields(0) & "'"
rs.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
ReDim Arr(rs.RecordCount) As Long
For J = 0 To rs.RecordCount - 1
Arr(J) = rs.Fields(0)
rs.MoveNext
Next
rs.MoveFirst
Do While Not rs.EOF
I = I + 1
If Arr(I) - rs.Fields(0) = 1 Then
If B Then
Str = Str & rs.Fields(0) & "-"
B = False
End If
Else
Str = Str & Arr(I - 1) & ","
B = True
End If
rs.MoveNext
Loop
rs.Close
If Len(Str) > 0 Then
Str = Left(Str, Len(Str) - 1)
End If
strLast = strLast & Rst.Fields(0) & "(" & Str & ")；"
Str = ""
Rst.MoveNext
Loop
Me.Text4 = strLast
Rst.Close
Set rs = Nothing
Set Rst = Nothing
End Sub

复制代码

Private Sub Command0_Click()
Dim rs As New ADODB.Recordset
Dim Rst As New ADODB.Recordset
Dim sSQL As String
Dim strSQL As String
Dim Arr() As Long '定义一个长整型的数组，来保存记录方便比对。
Dim Str As String, strLast As String
Dim I As Long, J As Long
Dim B As Boolean
sSQL = "SELECT DISTINCT 型号 FROM SN ORDER BY 型号"
Rst.Open sSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly '打开记录集提取型号作为下一个记录集的条件
Do While Not Rst.EOF '循环提取
I = 0
B = True '定义一个开关，为真时表示新的小单元开始（2-5）就是一个小单元
strSQL = "SELECT 序号 FROM SN WHERE 型号='" & Rst.Fields(0) & "' ORDER BY 序号"
rs.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly '以型号为条件打开第二个记录集
ReDim Arr(rs.RecordCount) As Long '重新定义一下数据元素，比记录数多一个，否则会溢出错误。
For J = 0 To rs.RecordCount - 1
Arr(J) = rs.Fields(0) '初始化数组，最后一个元素没有赋值，数据型默认为0
rs.MoveNext
Next
rs.MoveFirst
Do While Not rs.EOF
I = I + 1
If Arr(I) - Arr(I - 1) = 1 Then '把rs.Fields(0)改成Arr(I - 1)，也许你更容易理解
If B Then '如果符合你的条件，而且又是小单元开始，那么
Str = Str & Arr(I - 1) & "-"
B = False '这个时候就是小单元进行中，不是开始了，所以关掉。
End If
Else
Str = Str & Arr(I - 1) & "," '循环到条件不符，小单元结束，
B = True '新的小单元开始
End If
rs.MoveNext
Loop
rs.Close
If Len(Str) > 0 Then
Str = Left(Str, Len(Str) - 1)
End If
strLast = strLast & Rst.Fields(0) & "(" & Str & ");" '把循环结果跟型号括号连接起来，当然也可以把多余的逗号去掉
Str = "" '下一个型号开始前，把原来的结果清空
Rst.MoveNext
Loop
Me.Text4 = strLast '最后把结果赋给文本框，这个文本框是新添加的，不是你那个
Rst.Close
Set rs = Nothing
Set Rst = Nothing
End Sub

复制代码