Question

我有以.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

按照蒂姆的建议，我对代码的上方部分进行了如下更改。

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错误。

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

任何帮助将不胜感激。

谢谢。

Answer 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

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

1 个答案: