Excel VBA：将表数据导出到Access。如果2个字段的主键已经存在，如何覆盖？

问题描述 投票：1回答：1

我有以.xlsx格式导出的webi报告，其中包含3个选项卡中的3个表，我需要将其导出到Access数据库。

将要运行webi报告然后将数据从excel复制到访问的人位于海外，无法打开和使用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错误。

我能做错什么？我虽然它可能是日期格式，所以我试图手动匹配所有日期格式，导致相同的错误。

任何帮助，将不胜感激。

谢谢。

excel vba ms-access
1个回答
0
投票

要从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
最新问题
© www.soinside.com 2019 - 2024. All rights reserved.