Excel VBA将数据导出到MS Access表-扩展

Question

I'm trying to use the method that was described in one of the other threads that I saw posted on stackoverflow here .

When using the method that was described in that thread (that got the green check) I'm getting an error when running the code. The error pop-ups up a blank message box with no contents.

A couple of things to mention:

(1) I've made sure to select and activate the Microsoft Access 14.0 Object Library in Excel.

(2) I am running the sub procedure from my database worksheet in Excel.

(3) I am then running the AccImport procedure within my code procedure from my wizard worksheet in Excel (separate worksheet).

---

EXCEL SPREADSHEET SETUP

I can't use screenshots as of yet as I am new to the community but the database worksheet field range is setup as follows.

B1 (Occurrence Date), C1 (Machine), D2 (Cell), E2 (Status), F2 (Issue), G2(Preventative/Corrective), H2 (Assigned To)

B2 (15-APR-2015), C2(machine1), D2(cell1), E2 (0), F2(Test), G2 (Corrective), H2 (nameexample1)

---

ACCESS DATABASE TABLE IS SETUP AS FOLLOWS:

Table Name: MaintenanceDatabase

ID, Occurrence Date, Machine, Cell, Status, Issue, Preventative/Corrective Assigned To

Here is the code that I am running from the Database worksheet in Excel:

Sub AccImport()

    Dim acc As New Access.Application
    acc.OpenCurrentDatabase "C:\Users\brad.edgar\Desktop\DASHBOARDS\MAINTENANCE\MaintenanceDatbase.accdb"
    acc.DoCmd.TransferSpreadsheet _
        TransferType:=acImport, _
        SpreadsheetType:=acSpreadsheetTypeExcel12Xml, _
        TableName:="MaintenanceDatabase", _
        Filename:=Application.ActiveWorkbook.FullName, _
        HasFieldNames:=True, _
        Range:="Database$B1:H2"
    acc.CloseCurrentDatabase
    acc.Quit
    Set acc = Nothing

End Sub

Code Snippet from other Worksheet Object that Runs AccImport:

Public Sub DeleteSelectedRecord()
    Dim CurrentSelectedIndex    As Integer

    ' Assign the currently selected index to CurrentSelectedIndex
    CurrentSelectedIndex = [Database.CurrentIndex]

    ' Move the ListBox Selector
    If [Database.CurrentIndex].Value = [Database.RecordCount] Then    
'Last item on the list
        [Database.CurrentIndex].Value = [Database.CurrentIndex].Value - 1
    End If

    'Copy to Access Database

    Database.AccImport

    ' Delete the entry
    Database.ListObjects("Database").ListRows(CurrentSelectedIndex).Delete

End Sub

Hopefully someone could shed some light into why I'm getting an error.

Thanks in advance for any help.

Cheers,

Brad

Answer 1

I've never tried writing from excel to access in the way you've mentioned. Below is my preferred method. You'll need to use the Microsoft DAO object library but using a DAO object you can do updates, inserts, pulls, pretty much whatever you need to accomplish.

 Sub SaveCustomer_Defaults()

 Dim strSQL As Variant
 Dim accApp As Object
 Dim srcs As Variant
 Dim msg1 As Variant

 Sheets("Lists").Visible = True
 Sheets("Lists").Select
     Range("T6").Select
     x = Range("T500000").End(xlUp).Row

 For i = 6 To x
     Cells(i, 20).Select
     If Environ("USERNAME") = Cells(i, 23).Value Then
      'location of the access db   
      srcs = "C:\\user\desktop\Detail_1.accdb"  ''' Live location '''

    Set accApp = GetObject(srcs, "access.Application")

    'write your sql to pull the table along with the cell values
    strSQL = "Select * from US_CustomID "
    strSQL = strSQL & " where( [AssignedTo] = '" & Sheets("Lists").Cells(i, 21)
    strSQL = strSQL & "' and [Tab] = '" & Sheets("Lists").Cells(i, 24)
    strSQL = strSQL & "' and [RepID] = '" & Sheets("Lists").Cells(i, 23)
    strSQL = strSQL & "');"

    Set db = DAO.OpenDatabase(srcs)
    Set rs = db.OpenRecordset(strSQL)

    On Error Resume Next
    rs.Edit


    rs![Occurrence Date] = Sheets("Lists").Cells(i, 25)
    rs![Machine] = Sheets("Lists").Cells(i, 26)
    rs![Cell] = Sheets("Lists").Cells(i, 27)
    rs![Status] = Sheets("Lists").Cells(i, 28)
    rs![Issue] = Sheets("Lists").Cells(i, 29)
    rs![Preventative/Corrective] = Sheets("Lists").Cells(i, 30)
    rs![Assigned To] = Sheets("Lists").Cells(i, 31)

    rs.Update

    If Not rs Is Nothing Then rs.Close

    Set rs = Nothing
    Set db = Nothing

    accApp.DoCmd.RunSQL strSQL
    accApp.Application.Quit
        End If
    Next i

    Sheets("Lists").Visible = False

    End Sub