从excel导入订单及其明细

cnbobo

大家好：

我编好了一个订单输入的窗体，表和窗体的建立形式跟access自带的northwind的结构一样（其实我是跟着这个样板数据库学习的）。手工输入订单数据可以顺利进行。

我的问题是：我的同事是用excel将订单的信息发给我的，我无法从订单的窗体从excel导入订单及其明细。
有什么办法可以将订单及其明细直接从excel导入到access里面？

谢谢！

WDLRCZT

我提供一段代码让你参考

On Error GoTo Err_

If IsNull(Me.txtPath) = True Or Me.txtPath = "" Then
    MsgBox "请选择要导入的文件！", vbExclamation
    Exit Sub
End If

Dim adoConnection1 As New ADODB.Connection
Dim adoRecordset1 As New ADODB.Recordset
adoConnection1.Open "Data Provider=MSDASQL.1;driver=Microsoft Excel Driver (*.xls);DBQ=" & txtPath
adoRecordset1.Open "select * from [sheet1$]", adoConnection1, adOpenKeyset, adLockOptimistic

Dim I As Integer

For I = 1 To adoRecordset1.RecordCount - 1
    '判断费用是否正确
    If IsNumeric(adoRecordset1.Fields.item(4).Value) = False Then
        MsgBox "要导入的费用数据不正确，请更正后再导入！！", vbExclamation
        Exit Sub
    End If
   
    '判断科目是否在系统中存在
    Dim cn1 As Object, rs1 As Object, sql1 As String
    Set cn1 = Application.CurrentProject.Connection
    Set rs1 = CreateObject("adodb.recordset")
    sql1 = "select * from [tblDimCostAccount] where [CostAccountAlternateKey] =" & adoRecordset1.Fields.item(0).Value
    rs1.Open sql1, cn1, 1, 1
    If rs1.EOF Then
        MsgBox "要导入的科目系统中不存在，请更正后再导入！", vbExclamation
        Exit Sub
    End If
    rs1.Close
    cn1.Close

    '判断机台是否在系统中存在
    Dim cn2 As Object, rs2 As Object, sql2 As String
    Set cn2 = Application.CurrentProject.Connection
    Set rs2 = CreateObject("adodb.recordset")
    sql2 = "select * from [tblBaseData] where [Sort] ='" & "WorkCenterKey" & "'And [Value]='" & adoRecordset1.Fields.item(3).Value & "'"
    rs2.Open sql2, cn2, 1, 1
    If rs2.EOF Then
        MsgBox "要导入的机台系统中不存在，请更正后再导入！", vbExclamation
        Exit Sub
    End If
    rs2.Close
    cn2.Close
   
    adoRecordset1.MoveNext
Next I
adoRecordset1.Cancel
adoConnection1.Cancel

Dim adoConnection As New ADODB.Connection
Dim adoRecordset As New ADODB.Recordset
adoConnection.Open "Data Provider=MSDASQL.1;driver=Microsoft Excel Driver (*.xls);DBQ=" & txtPath
adoRecordset.Open "select * from [sheet1$]", adoConnection, adOpenKeyset, adLockOptimistic
Dim a As Integer

Dim cn As Object, rs As Object, sql As String
Set cn = Application.CurrentProject.Connection
Set rs = CreateObject("adodb.recordset")
sql = "select * from [tblFactWorkCenterKey]"
rs.Open sql, cn, 3, 3

If IsNull(DLookup("[ID]", "tblFactWorkCenterKey", "[CanlendarYear] ='" & Me.txtyear & "' And [CanlendarMonth]=" & Me.txtmonth & "")) = False Then
   
   If MsgBox(Me.txtyear & "年" & Me.txtmonth & "月的数据已经导入，是否要替换？", vbYesNo + vbQuestion) = vbYes Then
   
        DoCmd.SetWarnings 0
        DoCmd.RunSQL "DELETE * FROM tblFactWorkCenterKey WHERE (((tblFactWorkCenterKey.CanlendarYear)=[Forms]![pfrmImportFactWorkCenterKey]![txtYear]) AND ((tblFactWorkCenterKey.CanlendarMonth)=[Forms]![pfrmImportFactWorkCenterKey]![txtMonth]));"
        DoCmd.SetWarnings -1
        
        For a = 1 To adoRecordset.RecordCount - 1
            rs.AddNew
            rs("CanlendarYear") = Me.txtyear
            rs("CanlendarMonth") = Me.txtmonth
            rs("CostAccountAlternateKey") = adoRecordset.Fields.item(0).Value
            rs("WorkCenterKey") = adoRecordset.Fields.item(3).Value
            rs("TotalCost") = adoRecordset.Fields.item(4).Value
            rs.Update
            adoRecordset.MoveNext
        Next a
        
        rs.Close
        cn.Close
   
        Forms![frmFactWorkCenterKey]![Child4].Requery
        adoRecordset.Cancel
        adoConnection.Cancel
        MsgBox "数据导入成功！", vbInformation
    Else
        Exit Sub
    End If
Else
    For a = 1 To adoRecordset.RecordCount - 1
        rs.AddNew
        rs("CanlendarYear") = Me.txtyear
        rs("CanlendarMonth") = Me.txtmonth
        rs("CostAccountAlternateKey") = adoRecordset.Fields.item(0).Value
        rs("WorkCenterKey") = adoRecordset.Fields.item(3).Value
        rs("TotalCost") = adoRecordset.Fields.item(4).Value
        rs.Update
        adoRecordset.MoveNext
    Next a
    rs.Close
    cn.Close

    Forms![frmFactWorkCenterKey]![Child4].Requery
    adoRecordset.Cancel
    adoConnection.Cancel
    MsgBox "数据导入成功！", vbInformation
   
End If

Exit_:
    Exit Sub
Err_:
    If Err.Number = -2147467259 Then
        MsgBox "要导入的费用数据不正确，请更正后再导入！", vbExclamation
    Else
        MsgBox Err.Description
    End If
    Resume Exit_

cnbobo

非常感谢！
但是我是个access初学者，现在才刚刚开始学习vba，估计要3－5个月后才能看懂您给我的代码！
有没有其他一些手工操作的方法吗？

Grant

如果需要灵活操作excel这个是必须的
如果使用DoCmd.TransferSpreadsheet来导入excel灵活性没那么高
使用方法可查查帮助,很详尽.

andymark

有什么办法可以将订单及其明细直接从excel导入到access里面？

ACCESS本身自带导入向导

文件--获取外部数据--导入--文件类型(excel)

导入数据后可以再进一步处理(追加查询,更新查询)

cnbobo

各位：

关于这个“下标越界”的问题，一个偶然的机会，我已经解决：
“订单明细”表中的“订单明细ID"字段是自动编号的。
在从excel导入数据以前，订单明细ID的编号最后的编号是26；
当时，我在excel的数据中也有一个名为"订单明细ID"的字段，当时我们里面的数据有10个；"订单明细ID"的字段数值是27－36。
结果，当我们用access从excel中导入数据的时候，由于access中的”订单明细“表的"订单明细ID"的字段最后数值是26，但是excel中的数据是从27开始，所以access出现“下标越界”的错误，不让数据导入工作继续下去。

解决办法：
自己在access中的”订单明细“表中胡乱输入一些没有意义的数据，使得"订单明细ID"的字段的左后数值扩展到超过36。
然后删除这些没用的数据，但是"订单明细ID"的字段的数值不要删掉。
导入数据，这样就没有问题的。

希望对大家有帮助。

lisj

非常感谢！