Excel导入Access后建立
我提供一段代码让你参考
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 (*...全部
我提供一段代码让你参考
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( em(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(" cordset")
sql1 = "select * from [tblDimCostAccount] where [CostAccountAlternateKey] =" & em(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(" cordset")
sql2 = "select * from [tblBaseData] where [Sort] ='" & "WorkCenterKey" & "'And [Value]='" & em(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(" cordset")
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") = em(0)。Value
rs("WorkCenterKey") = em(3)。
Value
rs("TotalCost") = em(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") = em(0)。Value
rs("WorkCenterKey") = em(3)。
Value
rs("TotalCost") = em(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_
。收起