我这里有一个简单的表单,它使用 VBA Excel 中的代码连接到导出到 SharePoint 列表的 MS Access 数据库。由于我刚刚学习 Excel to Access,因此我只是从互联网上复制了以下代码并将其粘贴到 Excel VBA 模块中。该模块由表单的命令按钮调用。 该模块的目的是将Excel Sheet表中的数据添加到Access Database表中。该代码达到了其目的。
我的问题是,每次我点击按钮时,代码都会将数据从第1行保存到最后一行。当我点击按钮时,它会滞后。如果您可以看到下图,则表明行已成功保存,但它堆积在数据库中,这反映在 SharePoint 中。它已经达到 110 个条目,而在表中只有 19 个条目。
表格
基于导出的 MS Access 数据库表的 SharePoint 列表
每次点击按钮时我的预期结果是,它应该只保存我所做的最后一个条目或最后一行数据,而不是整个工作表。
这是命令按钮代码:
Option Explicit
Private Sub CommandButton1_Click()
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("Trial TRC")
Dim n As Long
n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row
sh.Range("A" & n + 1).Value = TextBox1.Value
sh.Range("B" & n + 1).Value = TextBox2.Value
sh.Range("C" & n + 1).Value = TextBox3.Value
Call AddRecordsIntoAccessTable
End Sub
这是模块:
Option Explicit
Sub AddRecordsIntoAccessTable()
'Declaring the necessary variables.
Dim accessFile As String
Dim accessTable As String
Dim sht As Worksheet
Dim lastRow As Long
Dim lastColumn As Integer
Dim con As Object
Dim rs As Object
Dim sql As String
Dim i As Long
Dim j As Integer
'Disable the screen flickering.
Application.ScreenUpdating = False
'Specify the file path of the accdb file. You can also use the full path of the file like this:
'AccessFile = "C:\Users\Christos\Desktop\Sample.accdb"
accessFile = ThisWorkbook.Path & "\" & "trialpower1.accdb"
'Ensure that the Access file exists.
If FileExists(accessFile) = False Then
MsgBox "The Access file doesn't exist!", vbCritical, "Invalid Access file path"
Exit Sub
End If
'Set the name of the table you want to add the data.
accessTable = "Trial_TRC"
'Set the worksheet that contains the data.
On Error Resume Next
Set sht = ThisWorkbook.Sheets("Trial TRC")
If Err.Number <> 0 Then
MsgBox "The given worksheet does not exist!", vbExclamation, "Invalid Sheet Name"
Exit Sub
End If
Err.Clear
'Find the last row and last column in the given worksheet.
With sht
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
End With
'Check if there are data in the worksheet.
If lastRow < 2 Or lastColumn < 1 Then
MsgBox "There are no data in the given worksheet!", vbCritical, "Empty Data"
Exit Sub
End If
'Create the ADODB connection object.
Set con = CreateObject("ADODB.connection")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "The connection was not created!", vbCritical, "Connection Error"
Exit Sub
End If
Err.Clear
'Open the connection.
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & accessFile
'Create the SQL statement to retrieve the table data (the entire table).
sql = "SELECT * FROM " & accessTable
'Create the ADODB recordset object.
Set rs = CreateObject("ADODB.Recordset")
'Check if the object was created.
If Err.Number <> 0 Then
Set rs = Nothing
Set con = Nothing
MsgBox "The recordset was not created!", vbCritical, "Recordset Error"
Exit Sub
End If
Err.Clear
'Set the necessary recordset properties.
rs.CursorType = 1 'adOpenKeyset on early binding
rs.LockType = 3 'adLockOptimistic on early binding
'Open the recordset.
rs.Open sql, con
'Add the records from Excel to Access by looping through the rows and columns of the given worksheet.
'Here the headers are in the row 1 and they are identical to the Access table headers.
'This is the reason why, for example, there are no spaces in the headers of the sample worksheet.
For i = 2 To lastRow
rs.AddNew
For j = 1 To lastColumn
'This is how it will look like the first time (i = 2, j = 1):
'rs("FirstName") = "Bob"
rs(sht.Cells(1, j).Value) = sht.Cells(i, j).Value
Next j
rs.Update
Next i
'Close the recordet and the connection.
rs.Close
con.Close
'Release the objects.
Set rs = Nothing
Set con = Nothing
'Re-enable the screen.
Application.ScreenUpdating = True
'Inform the user that the macro was executed successfully.
MsgBox lastRow - 1 & " rows were successfully added into the '" & accessTable & "' table!", vbInformation, "Done"
End Sub
Function FileExists(FilePath As String) As Boolean
'--------------------------------------------------
'Checks if a file exists (using the Dir function).
'--------------------------------------------------
On Error Resume Next
If Len(FilePath) > 0 Then
If Not Dir(FilePath, vbDirectory) = vbNullString Then FileExists = True
End If
On Error GoTo 0
End Function
请指教。谢谢你。
我更改了您可以看到的代码:
For i = 2 to lastRow
down to
Next i
这段代码:
i = sht.Range("A" & Application.Rows.Count).End(xlUp).Row
'x = 0
Do While Len(Range("A" & i).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
.Fields("Year") = Range("A" & i).Value
.Fields("MSID") = Range("B" & i).Value
.Fields("Date") = Range("C" & i).Value
.Update
'stores the new record
End With
i = i + 1
Loop
并且成功将Excel表中的1行数据添加到Access表中。