怎样按条件将一条记录拆分为几条记录？求助!

ljp518

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

ljp518

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

yehf

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

Henry D. Sy

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

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

ljp518

yehf老师！感谢你把代码有简化，使得运行更快！{:soso_e163:}

yehf

再简化下代码
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

谢谢Henry D. Sy老师的认真负责，值得敬佩的老师！按此程序进行修改。{:soso_e181:}

roych

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

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

Henry D. Sy

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
    

复制代码

ljp518

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