点击下载此附件

代码如下：

Private Sub btnImport_Click()
On Error GoTo ErrorHandler:
    Dim strSQL   As String
    Dim rst      As Object
    Dim cnn      As Object
    Dim rstXL    As Object
    Dim objExcel   As Object
    Dim objBook    As Object
    Dim objSheet   As Object
    Dim lngI       As Long
    
    If IsNull(Me.strFilePath) Then
        MsgBox "请先选择文件!", vbInformation, "提示"
        Me.strFilePath.SetFocus
        Exit Sub
    End If
    If IsNull(Me.strSheetName) Then
        MsgBox "请先选择Excel工作表!", vbInformation, "提示"
        Me.strSheetName.SetFocus
        Exit Sub
    End If
    
    
    
    '打开Access记录集
    Set rst = CreateObject("adodb.recordset")
    rst.Open "select * from tb_Parts where 1=2", CurrentProject.Connection, 1, 3
    
    '打开Excel
    Set objExcel = CreateObject("Excel.Application")
    Set objBook = objExcel.Workbooks.Open(Me.strFilePath)
    Set objSheet = objBook.WorkSheets("" & Me.strSheetName & "")
    objSheet.Select
    With objSheet
        For lngI = 2 To 65536  '循环行记录
            If .Cells(lngI, 1) = "" Then Exit For
            rst.AddNew
            rst![Part No] = .Cells(lngI, 1)
            rst![Part Name] = .Cells(lngI, 2)
            rst![Category] = .Cells(lngI, 3)
            rst![Part Type] = .Cells(lngI, 4)
            rst![Unit Cost] = .Cells(lngI, 5)
            rst![Cons Cost] = .Cells(lngI, 6)
            rst.Update
        Next
    End With

    rst.Close

    MsgBox "Import Success!"
    DoCmd.OpenTable "tb_Parts"
    
Exithere:
    DoCmd.Hourglass False
    If Not objBook Is Nothing Then objBook.Saved = True
    If Not objExcel Is Nothing Then objExcel.Quit
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objExcel = Nothing
    Set rst = Nothing
    Exit Sub

ErrorHandler:
        MsgBox Err.Description, vbInformation, "提示"
        Resume Exithere
End Sub

图   示: