设为首页收藏本站Access中国
开启辅助访问 切换到宽版

Office中国论坛/Access中国论坛

 找回密码
 注册

QQ登录

只需一步，快速开始

Office中国论坛/Access中国论坛»论坛首页 › ACCESS 与Sql Server 讨论区 › Access常规交流 › 数据转换问题
返回列表 发新帖
查看: 2925|回复: 8
打印 上一主题 下一主题

[模块/函数] 数据转换问题

[复制链接]
itydj
跳转到指定楼层
1#
发表于 2020-4-5 18:49:48 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
详细见附档


本帖子中包含更多资源

您需要 登录 才可以下载或查看，没有帐号？注册

x
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏1 分享分享 分享淘帖 订阅订阅
回复

使用道具 举报

Henry D. Sy
推荐
发表于 2020-4-6 01:49:17 | 只看该作者
中文字出现乱码，
...........
.........
重发

  1. Private Sub Command0_Click()
  2.     Dim rs As New ADODB.Recordset
  3.     Dim Rst As New ADODB.Recordset
  4.     Dim sSQL As String
  5.     Dim strSQL As String
  6.     Dim Arr() As Long
  7.     Dim Str As String, strLast As String
  8.     Dim I As Long, J As Long
  9.     Dim B As Boolean
  10.     sSQL = "SELECT DISTINCT 型号 FROM SN ORDER BY 型号"
  11.     Rst.Open sSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
  12.     Do While Not Rst.EOF
  13.         I = 0
  14.         B = True
  15.         strSQL = "SELECT 序号 FROM SN WHERE 型号='" & Rst.Fields(0) & "'"
  16.         rs.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
  17.         ReDim Arr(rs.RecordCount) As Long
  18.         For J = 0 To rs.RecordCount - 1
  19.             Arr(J) = rs.Fields(0)
  20.             rs.MoveNext
  21.         Next
  22.         rs.MoveFirst
  23.         Do While Not rs.EOF
  24.             I = I + 1
  25.             If Arr(I) - rs.Fields(0) = 1 Then
  26.                 If B Then
  27.                     Str = Str & rs.Fields(0) & "-"
  28.                     B = False
  29.                 End If
  30.             Else
  31.                 Str = Str & Arr(I - 1) & ","
  32.                 B = True
  33.             End If
  34.             rs.MoveNext
  35.         Loop
  36.         rs.Close
  37.         If Len(Str) > 0 Then
  38.             Str = Left(Str, Len(Str) - 1)
  39.         End If
  40.         strLast = strLast & Rst.Fields(0) & "(" & Str & ")；"
  41.         Str = ""
  42.         Rst.MoveNext
  43.     Loop
  44.     Me.Text4 = strLast
  45.     Rst.Close
  46.     Set rs = Nothing
  47.     Set Rst = Nothing
  48. End Sub
复制代码



点评

itydj
厉害了大神，能否详细标注一下，我要好好研究学习一下，感谢呀。  发表于 2020-4-7 11:52
回复 支持 1 反对 0

使用道具 举报

Henry D. Sy
2#
发表于 2020-4-6 01:46:45 | 只看该作者
  1. Private Sub Command0_Click()
  2.     Dim rs As New ADODB.Recordset
  3.     Dim Rst As New ADODB.Recordset
  4.     Dim sSQL As String
  5.     Dim strSQL As String
  6.     Dim Arr() As Long
  7.     Dim Str As String, strLast As String
  8.     Dim I As Long, J As Long
  9.     Dim B As Boolean
  10.     sSQL = "SELECT DISTINCT ??? FROM SN ORDER BY ???"
  11.     Rst.Open sSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
  12.     Do While Not Rst.EOF
  13.         I = 0
  14.         B = True
  15.         strSQL = "SELECT ??? FROM SN WHERE ???='" & Rst.Fields(0) & "'"
  16.         rs.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
  17.         ReDim Arr(rs.RecordCount) As Long
  18.         For J = 0 To rs.RecordCount - 1
  19.             Arr(J) = rs.Fields(0)
  20.             rs.MoveNext
  21.         Next
  22.         rs.MoveFirst
  23.         Do While Not rs.EOF
  24.             I = I + 1
  25.             If Arr(I) - rs.Fields(0) = 1 Then
  26.                 If B Then
  27.                     Str = Str & rs.Fields(0) & "-"
  28.                     B = False
  29.                 End If
  30.             Else
  31.                 Str = Str & Arr(I - 1) & ","
  32.                 B = True
  33.             End If
  34.             rs.MoveNext
  35.         Loop
  36.         rs.Close
  37.         If Len(Str) > 0 Then
  38.             Str = Left(Str, Len(Str) - 1)
  39.         End If
  40.         strLast = strLast & Rst.Fields(0) & "(" & Str & ")??"
  41.         Str = ""
  42.         Rst.MoveNext
  43.     Loop
  44.     Me.Text4 = strLast
  45.     Rst.Close
  46.     Set rs = Nothing
  47.     Set Rst = Nothing
  48. End Sub
复制代码
回复 支持 反对

使用道具 举报

Henry D. Sy
4#
发表于 2020-4-6 02:03:29 | 只看该作者
如果源数据的序号是乱序的，就加个排序
请把
  strSQL = "SELECT 序号 FROM SN WHERE 型号='" & Rst.Fields(0) & "'"
更换为如下:（加上红色那句）
  strSQL = "SELECT 序号 FROM SN WHERE 型号='" & Rst.Fields(0) & "' ORDER BY 序号"

点评

itydj
高手  发表于 2020-4-7 11:36
回复 支持 反对

使用道具 举报

tmtony

点击这里给我发消息
5#
发表于 2020-4-6 15:17:22 | 只看该作者
Henry D. Sy 发表于 2020-4-6 01:49
中文字出现乱码，
...........
.........

赞一个！
回复 支持 反对

使用道具 举报

ui
6#
发表于 2020-4-8 10:06:27 | 只看该作者
学习一下代码。赞一个
回复 支持 反对

使用道具 举报

Henry D. Sy
7#
发表于 2020-4-8 20:33:17 | 只看该作者
  1. Private Sub Command0_Click()
  2.     Dim rs As New ADODB.Recordset
  3.     Dim Rst As New ADODB.Recordset
  4.     Dim sSQL As String
  5.     Dim strSQL As String
  6.     Dim Arr() As Long    '定义一个长整型的数组，来保存记录方便比对。
  7.     Dim Str As String, strLast As String
  8.     Dim I As Long, J As Long
  9.     Dim B As Boolean
  10.     sSQL = "SELECT DISTINCT 型号 FROM SN ORDER BY 型号"
  11.     Rst.Open sSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly '打开记录集提取型号作为下一个记录集的条件
  12.     Do While Not Rst.EOF                                                   '循环提取
  13.         I = 0
  14.         B = True  '定义一个开关，为真时表示新的小单元开始（2-5）就是一个小单元
  15.         strSQL = "SELECT 序号 FROM SN WHERE 型号='" & Rst.Fields(0) & "' ORDER BY 序号"
  16.         rs.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockReadOnly  '以型号为条件打开第二个记录集
  17.         ReDim Arr(rs.RecordCount) As Long  '重新定义一下数据元素，比记录数多一个，否则会溢出错误。
  18.         For J = 0 To rs.RecordCount - 1
  19.             Arr(J) = rs.Fields(0)          '初始化数组，最后一个元素没有赋值，数据型默认为0
  20.             rs.MoveNext
  21.         Next
  22.         rs.MoveFirst
  23.         Do While Not rs.EOF
  24.             I = I + 1
  25.             If Arr(I) - Arr(I - 1) = 1 Then '把rs.Fields(0)改成Arr(I - 1)，也许你更容易理解
  26.                 If B Then                   '如果符合你的条件，而且又是小单元开始，那么
  27.                     Str = Str & Arr(I - 1) & "-"
  28.                     B = False               '这个时候就是小单元进行中，不是开始了，所以关掉。
  29.                 End If
  30.             Else
  31.                 Str = Str & Arr(I - 1) & ","  '循环到条件不符，小单元结束，
  32.                 B = True                     '新的小单元开始
  33.             End If
  34.             rs.MoveNext
  35.         Loop
  36.         rs.Close
  37.         If Len(Str) > 0 Then
  38.             Str = Left(Str, Len(Str) - 1)
  39.         End If
  40.         strLast = strLast & Rst.Fields(0) & "(" & Str & ");"  '把循环结果跟型号括号连接起来，当然也可以把多余的逗号去掉
  41.         Str = ""                         '下一个型号开始前，把原来的结果清空
  42.         Rst.MoveNext
  43.     Loop
  44.     Me.Text4 = strLast    '最后把结果赋给文本框，这个文本框是新添加的，不是你那个
  45.     Rst.Close
  46.     Set rs = Nothing
  47.     Set Rst = Nothing
  48. End Sub
复制代码



回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

QQ|站长邮箱|小黑屋|手机版|Office中国/Access中国 ( 粤ICP备10043721号-1 )  

GMT+8, 2024-11-29 02:12 , Processed in 0.113931 second(s), 37 queries .

Powered by Discuz! X3.3

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表