Excel VBA：将表数据导出到 Access。如果 2 个字段的主键已经存在，如何覆盖？
Posted
技术标签:
【中文标题】Excel VBA：将表数据导出到 Access。如果 2 个字段的主键已经存在，如何覆盖？【英文标题】：Excel VBA: Exporting table data to Access. How to overwrite if the Primary Key of 2 fields already exist? 【发布时间】：2018-08-30 00:02:14 【问题描述】：我以 .xlsx 格式导出了 webi 报告，其中包含来自 3 个选项卡的 3 个表，我需要将这些表导出到 Access 数据库。
要运行 webi 报告然后将数据从 excel 复制到 access 的人位于海外，无法打开和使用 Access 数据库本身。 （有访问但延迟问题让事情变得困难）
导出的 webi 报表不能附带宏，因此我创建了一个带有单个宏的 Excel 工作簿，该宏将从导出的 webi 报表中读取数据，然后将其添加到 Access 数据库中的现有表中。
如果数据库表中没有“匹配的主键”，则以下代码有效。但我需要对其进行改进，以便它使用匹配的主键覆盖任何数据并为新的主键创建新条目。
让事情变得复杂的是，3个表中有2个有2个字段作为主键，另一个表有3个字段作为主键。
有人可以帮我解决这个问题吗？ （如果我可以直接从 WebI 执行此操作，那就太棒了，但我找不到可行的解决方案。）
表1：
mDate：主键 国家：主键表2：
mDate：主键 国家：主键表3：
mDate：主键 mTime：主键 国家：主键VBA 代码：
Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
Dim wb As Workbook
Set wb = Workbooks("Exported_webi_Report")
Set wb1 = wb.Worksheets("tbl1")
Set wb2 = wb.Worksheets("tbl2")
Set wb3 = wb.Worksheets("tbl3")
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=\\networkdrive\database.accdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl1", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb1.Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("mDate") = wb1.Range("B" & r).Value
.Fields("Country") = wb1.Range("C" & r).Value
.Fields("1") = wb1.Range("D" & r).Value
.Fields("2") = wb1.Range("E" & r).Value
.Fields("3") = wb1.Range("F" & r).Value
.Fields("4") = wb1.Range("G" & r).Value
.Fields("5") = wb1.Range("H" & r).Value
.Fields("6") = wb1.Range("I" & r).Value
.Fields("7") = wb1.Range("J" & r).Value
.Fields("8") = wb1.Range("K" & r).Value
.Fields("9") = wb1.Range("L" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl2", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb2.Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("mDate") = wb2.Range("B" & r).Value
.Fields("Country") = wb2.Range("C" & r).Value
.Fields("1") = wb2.Range("D" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl3", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb3.Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("mDate") = wb3.Range("B" & r).Value
.Fields("mTime") = wb3.Range("C" & r).Value
.Fields("Country") = wb3.Range("D" & r).Value
.Fields("1") = wb3.Range("E" & r).Value
.Fields("2") = wb3.Range("F" & r).Value
.Fields("3") = wb3.Range("G" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
编辑::
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl1", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb1.Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("mDate") = wb1.Range("B" & r).Value
.Fields("Country") = wb1.Range("C" & r).Value
.Fields("1") = wb1.Range("D" & r).Value
.Fields("2") = wb1.Range("E" & r).Value
.Fields("3") = wb1.Range("F" & r).Value
.Fields("4") = wb1.Range("G" & r).Value
.Fields("5") = wb1.Range("H" & r).Value
.Fields("6") = wb1.Range("I" & r).Value
.Fields("7") = wb1.Range("J" & r).Value
.Fields("8") = wb1.Range("K" & r).Value
.Fields("9") = wb1.Range("L" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
按照 Tim 的建议，我将以上部分代码更改如下。
Dim sql As String, pk1 As Variant, pk2 As Variant, pk3 As Variant, pk As Variant
' open a recordset
Set rs = New ADODB.Recordset
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb1.Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
pk1 = wb1.Range("B" & r).Value
pk2 = wb1.Range("C" & r).Value
strSQL = "SELECT * " & _
"FROM tbl1 " & _
"WHERE [tbl1].[mDate] = # " & pk1 & " # " & _
"AND [tbl1].[Country] = ' " & pk2 & " ';"
.Open Source:=strSQL, _
ActiveConnection:=cn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdText
'if EOF add new record otherwise overwrite old record
If .EOF = True Then
.AddNew 'Create a new record
End If
' add values to each field in the record
.Fields("mDate") = pk1
.Fields("Country") = pk2
.Fields("1") = wb1.Range("D" & r).Value
.Fields("2") = wb1.Range("E" & r).Value
.Fields("3") = wb1.Range("F" & r).Value
.Fields("4") = wb1.Range("G" & r).Value
.Fields("5") = wb1.Range("H" & r).Value
.Fields("6") = wb1.Range("I" & r).Value
.Fields("7") = wb1.Range("J" & r).Value
.Fields("8") = wb1.Range("K" & r).Value
.Fields("9") = wb1.Range("L" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
Set rs = Nothing
运行时，它会尝试为现有日期添加新数据，并返回一条错误消息，指出我正在尝试制作重复的主键。
编辑#2
按照 Tim 的说明，我已经关闭了每个循环内的记录集，（日期和 # 之间没有空格）如下所示。
Dim sql As String, pk1 As Variant, pk2 As Variant, pk3 As Variant, pk As Variant
' open a recordset
Set rs = New ADODB.Recordset
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb1.Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
pk1 = wb1.Range("B" & r).Value
pk2 = wb1.Range("C" & r).Value
strSQL = "SELECT * " & _
"FROM tbl1 " & _
"WHERE [tbl1].[mDate] = #" & pk1 & "# " & _
"AND [tbl1].[Country] = ' " & pk2 & " ';"
.Open Source:=strSQL, _
ActiveConnection:=cn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdText
'if EOF add new record otherwise overwrite old record
If .EOF = True Then
.AddNew 'Create a new record
End If
' add values to each field in the record
.Fields("mDate") = pk1
.Fields("Country") = pk2
.Fields("1") = wb1.Range("D" & r).Value
.Fields("2") = wb1.Range("E" & r).Value
.Fields("3") = wb1.Range("F" & r).Value
.Fields("4") = wb1.Range("G" & r).Value
.Fields("5") = wb1.Range("H" & r).Value
.Fields("6") = wb1.Range("I" & r).Value
.Fields("7") = wb1.Range("J" & r).Value
.Fields("8") = wb1.Range("K" & r).Value
.Fields("9") = wb1.Range("L" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
rs.Close
Set rs = Nothing
Loop
现在，它在 8 月（30 日和 31 日）的最后几天运行良好。 但是一旦遇到 9 月 1 日，它就会尝试创建新记录并返回重复 pk 错误。
我做错了什么？我虽然可能是日期格式，所以我尝试手动匹配导致相同错误的所有日期格式。
任何帮助将不胜感激。
谢谢。
【问题讨论】：
对于每个表，您需要运行查询以查看是否存在现有匹配项（基于主键列）：如果存在则更新检索到的记录 - 如果没有匹配然后添加新记录；最后用更新/新记录更新记录集回数据库。冲洗/重复每个条目。 嗨蒂姆，感谢您的帮助，但我应该提到我对 Access 和 VBA 完全陌生。以上代码是搜索、复制和粘贴的结果。我能理解你的指示，但你能帮我写代码吗？ 我没有访问权限（或业余时间），所以我无法编写代码。将记录集Open 更改为使用 select * from tblt t where [add where clause here using the PK fields] 如果记录集不是 EOF，那么您有匹配的记录，因此更新非关键字段。如果记录集没有记录（EOF 为真），则完全按照代码中的方式使用 AddNew（但打开/更新/关闭需要在循环内）
嗨蒂姆，感谢您的帮助。我已尝试按照您的指示更改代码，您能否查看以上内容并找出我做错了什么？
您确定您的 sql 正在找到它应该找到的匹配项吗？您的日期值和 # 之间不应有空格。另外，您应该关闭循环内的记录集
【参考方案1】：
要从 Access 数据库中删除重复的 Table1，请尝试以下代码。
（未测试）
dim sql as string, pk1 as variant, pk2 as variant, pk3 as variant, pk as variant
dim i as long
with wb1
pk1 = application.transpose(.range(.range("B8"), .cells(.rows.count,2).end(xlup)).value)
pk2 = application.transpose(.range(.range("B8"), .cells(.rows.count,2).end(xlup)).offset(,1).value)
end with
for i = lbound(pk1) to ubound(pk1)
if pk1(i) > 0 then
if isarray(pk) then
redim preserve pk(ubound(pk)+1) as variant
else
redim pk(0) as variant
end if
pk(ubound(pk)) = "'" & format(pk1(i),"yyyymmdd") & "_" & pk2(i) & "'"
else
exit for
end if
next i
sql = "DELETE FROM tbl1 WHERE Format(mDate, ""yyyymmdd"") & ""_"" & country IN (" & join(pk, ", ") & ")"
cn.execute sql
【讨论】：
您好，PW，感谢您的帮助。我收到以下语法错误： sql = "DELETE FROM tbl1 WHERE Format(mDate,"yyyymmdd") & "_" & country IN (" & join(pk, ", ") & ")" 试试：sql = "DELETE FROM tbl1 WHERE Format(mDate, ""yyyymmdd"") & ""_"" & country IN (" & join(pk, ", ") & ")"
谢谢你，PW。你的小费我已经取得了很好的进展。但是由于一些奇怪的原因，它不会删除名为“Others”和“Philippines”的国家/地区字段，这会导致重复的 pk 错误。知道是什么原因造成的吗？
@DanielHuh 导致错误的原因有很多：您的 Excel 数据中可能出现拼写错误或不必要的空白。如果你想调试，错误信息是一个好的开始。以上是关于Excel VBA：将表数据导出到 Access。如果 2 个字段的主键已经存在，如何覆盖？的主要内容，如果未能解决你的问题，请参考以下文章
在Access和MSSqlserver里都有将表直接导出到Excel的工具