Office中国论坛/Access中国论坛

标题: 怎样按条件将一条记录拆分为几条记录？求助! [打印本页]

---

作者: ljp518    时间: 2011-9-23 08:45
标题: 怎样按条件将一条记录拆分为几条记录？求助!


[attach]46735[/attach] 由于银行控制>=5万元的付款，需要将贷方数>=5万元的付款记录，按姓名拆分成<5万元付款的若干条记录，不知vba函数怎样写，求助各位老师和版主！谢谢

---

作者: ljp518    时间: 2011-9-23 14:33
Private Sub Command0_Click()
    Dim rs As ADODB.Recordset
    Dim str As String
    Dim i As Integer
    Dim j As Integer
    Dim rs1 As ADODB.Recordset
    Dim str1 As String

    Set rs = New ADODB.Recordset
    Set rs1 = New ADODB.Recordset

    str = "select * from 表2"
    rs.Open str, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
    str1 = "select * from 表3"
    rs1.Open str1, CurrentProject.Connection, adOpenKeyset, adLockOptimistic

    If rs.EOF Then Exit Sub
    rs.MoveLast
    rs.MoveFirst

    Do Until rs.EOF
        j = rs(1) \ 1200
        If j > 0 Then
            For i = 1 To j
                rs1.AddNew
                rs1(1) = 1200
                rs1.Update
            Next i
            If rs(1) - 1200 * j <> 0 Then
                rs1.AddNew
                rs1(1) = rs(1) - 1200 * j
                rs1.Update
            End If

        Else
            rs1.AddNew
            rs1(1) = rs(1)
            rs1.Update
        End If

        rs.MoveNext
    Loop

    DoCmd.OpenTable "表3"

    rs.Close
    rs1.Close
    Set rs = Nothing
    Set rs1 = Nothing

End Sub

用这个拆分记录的函数如何修改为按姓名拆分，请各位老师帮助！谢谢！

---

作者: tzh16000    时间: 2011-9-23 15:42
看了下,应该把1200改成49999,表2为源表,表3为目标表
这里不是很懂,rs(1),是改成第N个字段的rs(N)呢?还是改成rs(字段名)?
请高手指教.

---

作者: ljp518    时间: 2011-9-23 16:13

tzh16000 发表于 2011-9-23 15:42
看了下,应该把1200改成49999,表2为源表,表3为目标表
这里不是很懂,rs(1),是改成第N个字段的rs(N)呢?还是改 ...

首先是谢谢关注，再等待高手的出手。。。

---

作者: roych    时间: 2011-9-23 19:21
代码都写出来了还求什么指教？{:soso_e128:}
简单注释下吧。
Private Sub Command0_Click()
    Dim rs As ADODB.Recordset
    Dim str As String
    Dim i As Integer
    Dim j As Integer
    Dim rs1 As ADODB.Recordset
    Dim str1 As String
    Set rs = New ADODB.Recordset
    Set rs1 = New ADODB.Recordset
    str = "select * from 表2"
    rs.Open str, CurrentProject.Connection, adOpenKeyset, adLockReadOnly
    str1 = "select * from 表3"
    rs1.Open str1, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    '如果不存在记录则跳出。
    If rs.EOF Then Exit Sub
'移动记录集位置，目的在于快速读取数据、
    rs.MoveLast
    rs.MoveFirst
'这一段主要是把记录新增到表3中。
'从这一段来看，表3的字段2跟表2的字段2必须是一样的字段类型。表2为输入，表3为输出。
    Do Until rs.EOF
'获取循环次数，即字段2（字段顺序是从0开始滴）的值除以1200取整
        j = rs(1) \ 1200
        If j > 0 Then
'如果大于1200，则按1200的倍数来执行循环
            For i = 1 To j
'设置rst1的字段2的值为1200
                rs1.AddNew
                rs1(1) = 1200
                rs1.Update
            Next i
'把整除后的余数作为新增记录添加上去。
'其实Else部分可以不写的，因为在前面已经把整除部分追加进去了。
            If rs(1) - 1200 * j <> 0 Then
                rs1.AddNew
                rs1(1) = rs(1) - 1200 * j
                rs1.Update
            End If

        Else
            rs1.AddNew
            rs1(1) = rs(1)
            rs1.Update
        End If
        rs.MoveNext
    Loop
'打开表3，关闭记录集，并释放内存。
    DoCmd.OpenTable "表3"
    rs.Close
    rs1.Close
    Set rs = Nothing
    Set rs1 = Nothing
End Sub

---

作者: ljp518    时间: 2011-9-28 09:07
太感谢roych 版主了，{:soso_e179:}由于这几天忙没有上论坛，本应在第一时间感谢！净拖了5天，真不好意思，表示歉意！

---

作者: Henry D. Sy    时间: 2011-9-28 15:07

1. Private Sub Command2_Click()
   
2.     Dim rs As New ADODB.Recordset
   
3.     Dim rs1 As New ADODB.Recordset
   
4.     Dim rs2 As New ADODB.Recordset
   
5.     Dim cnn As New ADODB.Connection
   
6.     Dim str As String
   
7.     Dim str1 As String
   
8.     Dim str2 As String
   
9.     Dim x As Double
   
10.     Dim y As Double
    
11.     Dim curM As Double
    
12.     Dim i As Integer
    
13. 
    
14.     On Error GoTo Command2_Click_Error
    
15. 
    
16.     Set cnn = CurrentProject.Connection
    
17.     i = 1
    
18.     CurrentDb.Execute "delete * from newtbl"
    
19.     Me.Newtbl_子窗体.Requery
    
20. 
    
21.     str = "SELECT DISTINCT 记录表.姓名 FROM 记录表"
    
22.     rs.Open str, cnn, adOpenKeyset, adLockReadOnly
    
23.     Do Until rs.EOF
    
24.         y = 50000
    
25.         str1 = "SELECT 贷方 FROM 记录表 WHERE 姓名='" & rs.Fields(0) & "' And Not 贷方 Is Null"
    
26.         rs1.Open str1, cnn, adOpenKeyset, adLockReadOnly
    
27.         x = rs1.Fields(0)
    
28. 
    
29.         str2 = "SELECT * FROM Newtbl"
    
30.         rs2.Open str2, cnn, adOpenKeyset, adLockOptimistic
    
31.         Do Until x <= 0
    
32. 
    
33.             If x >= 50000 Then
    
34.                 curM = y - i
    
35.                 x = x - y + i
    
36.             Else
    
37.                 curM = x
    
38.                 x = x - y
    
39.             End If
    
40.             i = i + 1
    
41.             rs2.AddNew
    
42.             rs2.Fields(0) = rs.Fields(0)
    
43.             rs2.Fields(1) = curM
    
44.             rs2.Update
    
45.         Loop
    
46.         rs2.Close
    
47.         rs1.Close
    
48.         rs.MoveNext
    
49.     Loop
    
50.     rs.Close
    
51.     Set rs = Nothing
    
52.     Set rs1 = Nothing
    
53.     Set rs2 = Nothing
    
54.     Set cnn = Nothing
    
55.     Me.Newtbl_子窗体.Requery
    
56. 
    
57.     On Error GoTo 0
    
58.     Exit Sub
    
59. 
    
60. Command2_Click_Error:
    
61. 
    
62.     MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
    
63. End Sub
    

复制代码

---

作者: roych    时间: 2011-9-28 21:36
标题: RE: 怎样按条件将一条记录拆分为几条记录？求助!

ljp518 发表于 2011-9-28 09:07
太感谢roych 版主了，由于这几天忙没有上论坛，本应在第一时间感谢！净拖了5天，真不好意思， ...

不客气。毛主席教导我们，要为人民服务嘛。能解决大家的问题，是我们莫大的荣幸。

---

作者: ljp518    时间: 2011-9-30 09:44
谢谢Henry D. Sy老师的认真负责，值得敬佩的老师！按此程序进行修改。{:soso_e181:}

---

作者: yehf    时间: 2011-9-30 16:37
再简化下代码
Private Sub Command2_Click()
    Dim rst    As Recordset
    Dim rst1   As Recordset
    Dim i      As Byte
    CurrentDb.Execute "delete * from newtbl"
    Set rst = CurrentDb.OpenRecordset("select * from 记录表 where 贷方>0")
    rst.MoveLast
    rst.MoveFirst
    Set rst1 = CurrentDb.OpenRecordset("newtbl")
    With rst1
        Do Until rst.EOF
            For i = 1 To Int(rst!贷方 / 50000)
               MsgBox rst!姓名
                .AddNew
                !姓名 = rst(1)
                !贷方 = 49999
                .Update
            Next
            .AddNew
            !姓名 = rst(1)
            !贷方 = rst(3) - 49999 * (i - 1)
            .Update
            rst.MoveNext
        Loop
    End With
    rst1.Close
    Set rst1 = Nothing
    rst.Close
    Set rst = Nothing
End Sub

---

作者: ljp518    时间: 2011-10-8 08:55
yehf老师！感谢你把代码有简化，使得运行更快！{:soso_e163:}

---

作者: Henry D. Sy    时间: 2011-10-8 09:47

yehf 发表于 2011-9-30 16:37
再简化下代码
Private Sub Command2_Click()
    Dim rst    As Recordset

lz要求，同一个人或者不同姓名，所有的尾数不同

---

作者: yehf    时间: 2011-10-8 14:42

Henry D. Sy 发表于 2011-10-8 09:47
lz要求，同一个人或者不同姓名，所有的尾数不同

增加两个变量进行换算,如果一拆分的尾数都要求不同,数据量大的话,也会不成立的,不知道楼主的数据量有多少条
Private Sub Command2_Click()
    Dim rst    As Recordset
    Dim rst1   As Recordset
    Dim i      As Byte
    Dim j      As Byte
    Dim k      As Integer
    j = 0
    k = 0
    CurrentDb.Execute "delete * from newtbl"
    Set rst = CurrentDb.OpenRecordset("select * from 记录表 where 贷方>0 ")
    rst.MoveLast
    rst.MoveFirst
    Set rst1 = CurrentDb.OpenRecordset("newtbl")
    With rst1
        Do Until rst.EOF
            For i = 1 To Int(rst!贷方 / 50000)
                .AddNew
                !姓名 = rst(1)
                !贷方 = 49999 - j
                .Update
                j = j + 1
                k = k + j
            Next
            .AddNew
            !姓名 = rst(1)
            !贷方 = rst(3) - 49999 * (i - 1) + IIf(rst!贷方 > 50000, k - i + 1, 0)
            .Update
            rst.MoveNext
            k = 0
        Loop
    End With
    rst1.Close
    Set rst1 = Nothing
    rst.Close
    Set rst = Nothing
End Sub

---

作者: ljp518    时间: 2011-10-8 15:00


谢谢Henry D. Sy 老师和yehf老师，感谢两位老师的帮助！{:soso_e163:}{:soso_e163:}

---

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)

Powered by Discuz! X3.3