Excel VBA: экспорт данных таблицы в Access. Как перезаписать, если первичный ключ из 2 полей уже существует? - PullRequest
Новая
       7

Excel VBA: экспорт данных таблицы в Access. Как перезаписать, если первичный ключ из 2 полей уже существует?

0 голосов
/ 30 августа 2018

У меня экспортирован веб-отчет в формате .xlsx с 3 таблицами из 3 вкладок, которые необходимо экспортировать в базу данных Access.

Человек, который собирается запустить веб-отчет, а затем скопировать данные из Excel для доступа, находится за рубежом и не может открывать и работать с самой базой данных Access. (Имеет доступ, но проблема с задержкой усложняет задачу)

Экспортированный веб-отчет не может содержать макрос, поэтому я создал книгу Excel с одним макросом, который будет считывать данные из экспортированного веб-отчета и затем добавлять их в существующие таблицы в базе данных Access.

Код ниже работает, если в таблицах базы данных нет «совпадающих первичных ключей». Но мне нужно улучшить его, чтобы он перезаписывал любые данные соответствующими первичными ключами и создавал новые записи для новых первичных ключей.

Что усложняет ситуацию, так это то, что 2 из 3 таблиц имеют 2 поля в качестве первичного ключа, а другая таблица имеет 3 поля в качестве первичного ключа.

Может кто-нибудь помочь мне с этим вопросом, пожалуйста? (Если бы я мог сделать это прямо из WebI, это было бы замечательно, но я не смог бы найти рабочее решение.)

Table1:

  • mDate: первичный ключ
  • Страна: первичный ключ

Table2:

  • 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

EDIT :: 

' 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

Продолжая инструкции Тима, я закрыл набор записей внутри каждого цикла (и без пробелов между датами и #), как показано ниже. 

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

Теперь, это работало хорошо в последние пару дней в августе (30 и 31). Но как только он сталкивается с 1 сентября, он пытается создать новую запись и возвращается с повторяющейся ошибкой pk.

Что я мог делать не так? Я подумал, что это может быть формат даты, поэтому я попытался вручную сопоставить все форматы даты, что привело к той же ошибке.

Буду признателен за любую помощь.

Спасибо.

1 Ответ

0 голосов
/ 30 августа 2018

Чтобы удалить дубликаты Table1 из базы данных Access, попробуйте код ниже. (не проверено) 

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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Нет похожих вопросов

...