通过excel vba同时添加和更新访问权限

时间：2018-08-03 23:05:00

标签： excel vba excel-vba ms-access access-vba

我有一个要从excel vba更新的访问表。新数据来自已保存的excel文件，每一行都有一个唯一的ID作为其主键。我要这样做，以便在输入新数据时，将替换主键与新条目的主键匹配的任何现有条目，并且任何不替换旧条目的新数据都将创建一个新条目。我相信这称为左联接或右联接，但是我不确定。目前，我的代码仅添加了一个新的记录集，而我似乎无法使其加入联接，因为我对Access vba不太熟悉，也没有使excel和Access互相交谈。

这是我的代码，是从excel运行的：

Function AppendShipment(DatabaseLocation, ExcelFileLocation, dbTableName)
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet

Set wkb = Workbooks.Open(ExcelFileLocation)
Set wks = wkb.Worksheets("Sheet1")

Dim strConnection As String
Dim db As Object
Dim rs As Object
Dim r As Integer

Application.ScreenUpdating = False

strConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & 
DatabaseLocation

Set db = CreateObject("ADODB.Connection")
    db.Open strConnection
    ' open a recordset
Set rs = CreateObject("ADODB.Recordset")
    rs.Open dbTableName, db, adOpenKeyset, adLockOptimistic


r = 2 ' the start row in the worksheet
    Do While Not Cells(r, 1) = ""
    ' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields("Customer") = Range("A" & r).Value
            .Fields("Customer Name") = wks.Range("B" & r).Value
            .Fields("Order Date") = wks.Range("C" & r).Value
            .Fields("Contract") = wks.Range("D" & r).Value
            .Fields("Sales Order") = wks.Range("E" & r).Value
            .Fields("Line#") = wks.Range("F" & r).Value
            .Fields("Customer Part") = wks.Range("G" & r).Value
            .Fields("AFS Part") = wks.Range("H" & r).Value
            .Fields("Decription 1") = wks.Range("I" & r).Value
            .Fields("Site") = wks.Range("J" & r).Value
            .Fields("Product Code") = wks.Range("K" & r).Value
            .Fields("Qty Ship") = wks.Range("L" & r).Value
            .Fields("Unit Price") = wks.Range("M" & r).Value
            .Fields("Customer PO Number") = wks.Range("N" & r).Value
            .Fields("Invoice Date") = wks.Range("O" & r).Value
            .Fields("Ship Date") = wks.Range("P" & r).Value
            .Fields("Ship To") = wks.Range("Q" & r).Value
            .Fields("Shipped-Dollars") = wks.Range("R" & r).Value
            .Fields("Month1") = wks.Range("S" & r).Value
            .Fields("Year1") = wks.Range("Y" & r).Value
            .Fields("Product Line") = wks.Range("U" & r).Value
            .Fields("Customer Group") = wks.Range("V" & r).Value
            .Fields("Customer&Product") = wks.Range("W" & r).Value
            .Fields("Customer Group 2") = wks.Range("X" & r).Value
            .Fields("Product Subgroup (Type 1)") = wks.Range("Y" & r).Value
            .Fields("Product Subgroup (Type 2)") = wks.Range("Z" & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record
        End With
        r = r + 1 ' next row
    Loop
rs.Close
db.Close

ActiveWorkbook.Close SaveChanges:=False

Application.ScreenUpdating = True

End Function

感谢您的帮助，谢谢！

2 个答案:

答案 0 :(得分：1)

仅当查询有权访问源数据时，才可以在MS Access中将JOIN用作“ UPSERT”。在您的情况下，源数据在Excel中，因此您必须分别处理每一行。我建议在数据库中搜索唯一键，以确定是添加新记录还是编辑现有记录：

' repeat until first empty cell in column A
With rs
    .FindFirst "[Sales Order]=" & wks.Range("E" & r).Value & _
        " AND [Line#] = " & wks.Range("F" & r).Value
    If .NoMatch Then .AddNew Else .Edit  ' create a new or edit existing record
    ' add values to each field in the record
    .Fields....

由于看不到您的数据类型，因此我假设[Sales Order]和[Line#]都是数字。如果没有，则必须将单引号引起来，并调用.FindFirst方法。

答案 1 :(得分：0)

我知道了！

首先，我使用.Filter查看是否有任何与当前记录匹配的内容。如果.RecordCount = 0，则没有匹配项，因此它将执行.AddNew。如果确实匹配，则表明.Edit对ADO不起作用，而需要使用.MoveFirst。由于只有1个记录集会匹配，因为我正在按主键进行筛选，并且不能有重复项，所以这将编辑该记录集没有问题。

Function AppendShipment(DatabaseLocation, ExcelFileLocation, dbTableName)
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet

Set wkb = Workbooks.Open(ExcelFileLocation)
Set wks = wkb.Worksheets("Sheet1")

Dim strConnection As String
Dim db As Object
Dim rs As Object
Dim r As Integer

Application.ScreenUpdating = False

strConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & DatabaseLocation

Set db = CreateObject("ADODB.Connection")
    db.Open strConnection
    ' open a recordset
Set rs = CreateObject("ADODB.Recordset")
    rs.Open dbTableName, db, adOpenKeyset, adLockOptimistic


r = 2 ' the start row in the worksheet
    Do While Not Cells(r, 1) = ""
    ' repeat until first empty cell in column A
        With rs
            Debug.Print "[UniqueDB_ID]=" & "'" & Trim(wks.Range("E" & r).Value) & 
wks.Range("F" & r).Value & "'"
        .Filter = "[UniqueDB_ID]=" & "'" & Trim(wks.Range("E" & r).Value) & 
wks.Range("F" & r).Value & "'"
        If .RecordCount = 0 Then .AddNew Else .MoveFirst  ' create a new record or 
edit existing record
        ' add values to each field in the record
        .Fields("UniqueDB_ID") = Trim(wks.Range("E" & r).Value) & wks.Range("F" & 
r).Value
        .Fields("Customer") = wks.Range("A" & r).Value
        .Fields("Customer Name") = wks.Range("B" & r).Value
        .Fields("Order Date") = wks.Range("C" & r).Value
        .Fields("Contract") = wks.Range("D" & r).Value
        .Fields("Sales Order") = Trim(wks.Range("E" & r).Value)
        .Fields("Line#") = wks.Range("F" & r).Value
        .Fields("Customer Part") = wks.Range("G" & r).Value
        .Fields("AFS Part") = wks.Range("H" & r).Value
        .Fields("Decription 1") = wks.Range("I" & r).Value
        .Fields("Site") = wks.Range("J" & r).Value
        .Fields("Product Code") = wks.Range("K" & r).Value
        .Fields("Qty Ship") = wks.Range("L" & r).Value
        .Fields("Unit Price") = wks.Range("M" & r).Value
        .Fields("Customer PO Number") = wks.Range("N" & r).Value
        .Fields("Invoice Date") = wks.Range("O" & r).Value
        .Fields("Ship Date") = wks.Range("P" & r).Value
        .Fields("Ship To") = wks.Range("Q" & r).Value
        .Fields("Shipped-Dollars") = wks.Range("R" & r).Value
        .Fields("Month1") = wks.Range("S" & r).Value
        .Fields("Year1") = wks.Range("Y" & r).Value
        .Fields("Product Line") = wks.Range("U" & r).Value
        .Fields("Customer Group") = wks.Range("V" & r).Value
        .Fields("Customer&Product") = wks.Range("W" & r).Value
        .Fields("Customer Group 2") = wks.Range("X" & r).Value
        .Fields("Product Subgroup (Type 1)") = wks.Range("Y" & r).Value
        .Fields("Product Subgroup (Type 2)") = wks.Range("Z" & r).Value
        ' add more fields if necessary...
        .Update ' stores the new record
    End With
    r = r + 1 ' next row
    Loop
rs.Close
db.Close

ActiveWorkbook.Close SaveChanges:=False

Application.ScreenUpdating = True

End Function

谢谢您的帮助！

相关问题
最新问题