如何将二段代码合并在一起

hqlin65

各位老师好！！下面二段代码分别运行可以，但怎么才能将它们合并在一起运行？

Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset

Private Sub UserForm_Initialize() '
Stpath = ThisWorkbook.Path & "\数据库.mdb"
   cnn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & Stpath
   Sql = "Select distinct 收据编号  from 资料 order by 收据编号"
  
   rst.Open Sql, cnn, adOpenKeyset, adLockOptimistic
   rst.MoveFirst
    Do Until rst.EOF
        'Label5 = Format(Val(rst.Fields("收据编号")) + 1, "00000000")
        Label12 = Sheet1.Range("a7")
        Label3 = Sheet1.Range("a6")
        Label4 = Format(Date, "yyyy年mm月dd日")
      
        rst.MoveNext
   Loop
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing

End Sub


Private Sub UserForm_Initialize() '
Stpath = ThisWorkbook.Path & "\数据库.mdb"
   cnn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & Stpath
   Sql = "Select distinct 名称 from 款项来源 order by 名称"
   rst.Open Sql, cnn, adOpenKeyset, adLockOptimistic
   rst.MoveFirst
    Do Until rst.EOF
      
        ComboBox1.AddItem rst("名称")
        rst.MoveNext
   Loop
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing

End Sub


关键点在于同一个数据库，同一个窗体，要引用数据库中二个不同表的字段。
请各们大侠指点一下，谢谢！！！

microyip

有点不是很明白，为什么不停循环给Label写值，你不干脆取最后一个值就完了吗？循环写Label的结果就是写最后的值

microyip

1. Dim cnn As New ADODB.Connection
   
2. Dim rst As New ADODB.Recordset
   
3. 
   
4. Private Sub UserForm_Initialize() '
   
5.     Dim sPath As String, sSQL As String, vRS As Variant, vList As Variant, nI As Double
   
6.    
   
7.     sPath = ThisWorkbook.Path & "\数据库.mdb"
   
8.     cnn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & sPath
   
9.     sSQL = "Select Max([收据编号]) From [资料]"
   
10.    
    
11.     rst.Open sSQL, cnn, adOpenKeyset, adLockOptimistic
    
12.     If Not (rst.EOF And rst.BOF) Then
    
13.         vRS = rst.GetRows
    
14.         Label5 = Format(Val(vRS(0, 0)) + 1, "00000000")
    
15.     Else
    
16.         Label5 = "00000001"
    
17.     End If
    
18.     Label12 = Sheet1.Range("a7")
    
19.     Label3 = Sheet1.Range("a6")
    
20.     Label4 = Format(Date, "yyyy年mm月dd日")
    
21.     rst.Close
    
22. 
    
23.     sSQL = "Select distinct 名称 from 款项来源 order by 名称"
    
24.     rst.Open sSQL, cnn, adOpenKeyset, adLockOptimistic
    
25.     If Not (rst.EOF And rst.BOF) Then
    
26.         vRS = rst.GetRows
    
27.         ReDim vList(1 To UBound(vRS, 2) + 1)
    
28.         For nI = 0 To UBound(vRS, 2)
    
29.             If Not IsNull(vRS(0, nI)) Then vList(nI + 1) = vRS(0, nI)
    
30.         Next
    
31.         ComboBox1.List = vList
    
32.     End If
    
33.     rst.Close
    
34.     cnn.Close
    
35.     Set rst = Nothing
    
36.     Set cnn = Nothing
    
37. 
    
38. End Sub

复制代码

microyip

附上附件以供参考

hqlin65

microyip 发表于 2020-11-23 00:39
附上附件以供参考

很完美。太感谢您了，我好好学习。

hqlin65

microyip 发表于 2020-11-23 00:39
附上附件以供参考

我今天捣鼓了一天，都没办法把窗体上的资料：日期、收据编号、客户、事由、备注、制单人、金额、款项来源等保存到数据库中。如果您有空请再帮帮我。实在麻烦您了，谢谢！！

hqlin65

microyip 发表于 2020-11-23 00:39
附上附件以供参考

老师您好！我凑了下面一段代码，可以将窗体上的资料保存到数据库中了，但我想要加“收据编号”相同不能保存的提示，一直弄不好，您好能不能帮我看一下？谢谢！

Private Sub CommandButton1_Click()
Dim sPath As String, sSQL As String, vRS As Variant, vList As Variant, nI As Double
sPath = ThisWorkbook.Path & "\数据库.mdb"
    cnn.Open "provider=Microsoft.jet.OLEDB.4.0;data source=" & sPath
sSQL = "Select * from 资料 "
RSt.Open sSQL, cnn, adOpenKeyset, adLockOptimistic

With RSt
      .AddNew
    .Fields("日期") = Label4
    .Fields("客户") = TextBox1.Text
    .Fields("事由") = TextBox2.Text
    .Fields("备注") = TextBox3.Text
    .Fields("金额") = TextBox4
     .Fields("款项来源") = ComboBox1.Value
    .Fields("制单人") = Label12
    .Fields("收据编号") = Label5
        .Update
        MsgBox "已推送财务!"
    End With
     TextBox1.Text = ""
     TextBox2.Text = ""
     TextBox3.Text = ""
     TextBox4.Text = ""
     ComboBox1.Value = ""
     RSt.Close
    cnn.Close
    Set RSt = Nothing
    Set cnn = Nothing
    Call UserForm_Initialize
End Sub

魂断蓝桥

hqlin65 发表于 2020-11-23 22:34
老师您好！我凑了下面一段代码，可以将窗体上的资料保存到数据库中了，但我想要加“收据编号”相同不能保 ...

1、收据编号定义为唯一索引，如果有重复的会报错

比如用代码

Sub A()
    Dim cnn, rs, Sql$
    Set cnn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("adodb.Recordset")
    cnn.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\test.mdb"
    On Error GoTo 100
    Sql = "select * from 表1"
    rs.Open Sql, cnn, 1, 3
    With rs
        .AddNew
        .Fields("id") = 3
        .Update
    End With
    Set rs = Nothing
    Set cnn = Nothing
    MsgBox "插入OK"
    Exit Sub
100:
    MsgBox Err.Description & vbLf & Err.Number
    Set rs = Nothing
    Set cnn = Nothing
End Sub

2、插入前先查询一下是否有重复的单据编号
Sub b()
    Dim cnn, rs, Sql$
    Set cnn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("adodb.Recordset")
    cnn.Open "provider=microsoft.ace.oledb.12.0;data source=" & ThisWorkbook.Path & "\test.mdb"
    Sql = "select * from 表1 where id=5"
    rs.Open Sql, cnn, 1, 3
    If rs.RecordCount = 0 Then
        With rs
            .AddNew
            .Fields("id") = 5
            .Update
        End With
    Else
        MsgBox "id 重复不能录入"
        Exit Sub
    End If
    Set rs = Nothing
    Set cnn = Nothing
    MsgBox "插入OK"
End Sub

hqlin65

魂断蓝桥 发表于 2020-11-24 09:35
1、收据编号定义为唯一索引，如果有重复的会报错

比如用代码

非常感谢您的帮助，我试试看。再次感谢！

陕西二蛋

三组代码,合并后各自都能运行,我多次实验过,始终无法完整的运行,跪求各位大神,帮助我修改一下,
1.权限登录窗体代码
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.DisplayAlerts = False
ActiveWorkbook.Save '保存当前工作簿文档
End Sub

Private Sub Workbook_Open()
Application.Visible = 0
login.Show '加载登录窗体
Application.Visible = True
End Sub



2.设定日期 .超出日期自毁代码
Option Explicit
Sub KillThisWorkbook()
With ThisWorkbook
.Saved = True
.ChangeFileAccess xlReadOnly
Kill .FullName
.Close
End With
End Sub

Private Sub Workbook_Open()
If Date > #2/22/2022# Then
Call KillThisWorkbook
End If
End Sub



3.硬盘序列号,设限使用,非指定用户.文件自毁
Private Declare PtrSafe Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Sub Workbook_Open()
Dim str As String * 100
Dim ovp As Long
Dim cpn As String
ovp = 99
cpn = GetHardDiskInfo(hdPrimaryMaster, hdOnlySN)
If cpn <> "RW103005B6314" Then '你指定的用户
MsgBox "非指定用户，文件将自毁！"
Call Killme
End If
End Sub

Sub Killme()
Application.DisplayAlerts = False
With ActiveWorkbook
.ChangeFileAccess xlReadOnly
Kill .FullName
wbClose_1
End With
End Sub