如何传输VBA UserForm数据访问数据库?

Question

我在excel中创建了一个用户表单，以将我的记录保存在sheet1这样的工作表中。但是在使用这个UserForm几天之后，它的速度变慢了，因为在sheet1中保存了大量的数据。现在我想将所有记录保存到数据库中，并希望保持我的工作表干净。因此，我可以轻松地或没有任何延迟地处理我的UserForm。还想通过序列号更新我的记录。但是我不想在我的工作表上做任何记录。

我的小代码如下:-

Sub cmdAdd_Click()
On Error GoTo ErrOccured
BlnVal = 0
If BlnVal = 0 Then Exit Sub

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim txtId, txtName, GenderValue, txtLocation, txtCNum, txtEAddr, txtRemarks
Dim iCnt As Integer

iCnt = fn_LastRow(Sheets("Data")) + 1

If frmData.obMale = True Then
GenderValue = "Male"
Else
GenderValue = "Female"
End If
With Sheets("Data")
.Cells(iCnt, 1) = iCnt - 1
.Cells(iCnt, 2) = frmData.txtName
.Cells(iCnt, 3) = GenderValue
.Cells(iCnt, 4) = frmData.txtLocation.Value
.Cells(iCnt, 5) = frmData.txtEAddr
.Cells(iCnt, 6) = frmData.txtCNum
.Cells(iCnt, 7) = frmData.txtRemarks

.Columns("A:G").Columns.AutoFit
.Range("A1:G1").Font.Bold = True
.Range("A1:G1").LineStyle = xlDash

End If
End With
Dim IdVal As Integer
IdVal = fn_LastRow(Sheets("Data"))
frmData.txtId = IdVal

ErrOccured:
'TurnOn screen updating
Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

我将永远感激你。

Answer 1

那么，请尝试下一种方式。我将尝试使用Excel VBA创建必要的DB，表和字段:

1. 复制下一段代码，它将在你想要的路径上创建一个空的DB:

Sub CreateEmptyDB()
Dim strPath As String, objAccess As Object
strPath = "C:Your pathtestDB"
Set objAccess = CreateObject("Access.Application")
Call objAccess.NewCurrentDatabase(strPath)
objAccess.Quit
End Sub

2. 以编程方式创建包含其字段的必要表(添加' start Date'只是为了查看如何处理此类数据…):

Sub createTableFields()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim Catalog As Object, cn As ADODB.Connection
Dim dbPath As String, scn As String, strTable As String
dbPath = "C:Teste VBA ExceltestAccesstestDB.accdb"
strTable = "MySpecial_Table"

scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
Set Catalog = CreateObject("ADOX.Catalog")
Set cn = New ADODB.Connection
With cn
.Open scn
.Execute "CREATE TABLE " & strTable & " ([Name] text(255) WITH " & _
"Compression, " & "[Gender] text(255) WITH Compression, " & _
"[Location] text(255) WITH Compression, " & _
"[Address] text(255) WITH Compression, " & _
"[Number] number, " & _
"[Remarks] text(255) WITH Compression, " & _
"[Start Date] datetime)"
End With
cn.Close
End Sub

3. 添加记录到新创建的DB/Table:

Sub FillDataInDB()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim AccessDB As String, strTable As String, sql As String
Dim con As ADODB.Connection, rs As ADODB.Recordset, lastNo As Long

AccessDB = "C:Teste VBA ExceltestAccesstestDB.accdb"
strTable = "MySpecial_Table"

Set con = CreateObject("ADODB.connection")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB

sql = "SELECT * FROM " & strTable
Set rs = CreateObject("ADODB.Recordset")
rs.CursorType = 1   'adOpenKeyset on early binding
rs.LockType = 3     'adLockOptimistic on early binding

rs.Open sql, con
If rs.RecordCount = 0 Then
lastNo = 0 'when no records in the table
Else
rs.MoveLast: lastNo = rs("Number") 'the last recorded value
End If
rs.AddNew
rs("Name") = "Test name"              'frmData.txtName
rs("Gender") = "Test gender"          'GenderValue
rs("Location") = "Test Location"      'frmData.txtLocation.Value
rs("Address") = "Test Address"        'frmData.txtEAddr
rs("Number") = IIf(lastNo = 0, 100, lastNo + 1) 'auto incrementing against the last value
'but starting from 100
'you can use frmData.txtCNum
rs("Remarks") = "Remarkable table..." 'frmData.txtRemarks
rs("Start Date") = Date
rs.Update
rs.Close: con.Close

Set rs = Nothing: Set con = Nothing
End Sub

4. 按连续顺序运行前两段代码(只运行一次)，然后开始运行第三段代码…

5. 您可以通过以下方式读取新创建的DB表(在Excel工作表中返回):

Sub ADO_Connection_ReadTable()
Dim conn As New Connection, rec As New Recordset, sh As Worksheet
Dim AccessDB As String, connString, query As String, strTable As String

AccessDB = "C:Teste VBA ExceltestAccesstestDB.accdb"
strTable = "MySpecial_Table"
Set sh = ActiveSheet 'use here the sheet you want
connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB

conn.Open connString
query = "SELECT * from " & strTable & ";"

rec.Open query, conn
'return in the sheet
sh.cells.ClearContents
'getting data from the recordset if any and returning some in columns A:B:
If (rec.RecordCount <> 0) Then
Do While Not rec.EOF
With sh.Range("A" & sh.cells(Rows.count, 1).End(xlUp).row).Offset(1, 0)
.Value2 = rec.fields(0).Value
.Offset(0, 1).Value2 = rec.fields(3)
End With
rec.MoveNext
Loop
End If
rec.Close: conn.Close
End Sub

可以使用查询来根据特定的表字段返回特定的数据。你可以在网上找到很多例子。

我还试图展示如何处理"数字"字段的自动记录。当然，如果你能以不同的方式记录它，你可以在你需要/不需要的时候记录它。

请测试上述代码并发送一些反馈。您可以在模块级别使用DB路径作为Private常数，并使用许多其他方法来优化代码。这只是一个最低限度的可行解决方案，只是展示了道路…:)