Office中国论坛/Access中国论坛

标题: 如何将excel数据导入access? [打印本页]

作者: SRONE 时间: 2009-3-20 09:23
标题: 如何将excel数据导入access?

请问各位大侠，能否用程序把excel数据导入access的表单中，但是EXCEL表格中的表头不需要导入ACCESS中，以后只要把EXCEL表格中新增加的数据追加到原ACCESS的相应表单中即可，同时能自动删除EXCEL表格中的数据。

作者: SRONE 时间: 2009-3-20 09:25
请高手多指点指点

作者: SRONE 时间: 2009-3-20 09:26
以下的程序，请各位大师帮我指点一下

Private Sub cmd导入_Click()

On Error Resume Next
Dim exapp As New Excel.Application
Dim exBook As Excel.Workbook
Dim exSheet As Excel.Worksheet
Dim i As Integer
Dim strName As String
Set exBook = exapp.Workbooks.Open(CurrentProject.Path & "\扣罚款单工作薄.xls")
For i = 2 To exBook.Sheets.Count
DoCmd.TransferSpreadsheet acImport, , "KFKtable", CurrentProject.Path & _
"\扣罚款单工作薄.xls", True, exBook.Worksheets(i).name & "!"
Next
exBook.Close
Set exBook = Nothing
exapp.Quit

End Sub

作者: wuheng 时间: 2009-3-20 09:27
自己动手SOU一下,好象有蛮多例子的,

作者: narcissus82 时间: 2009-3-20 10:22
我刚好有个例子，你可以自己研究下！

Public Function OpenEXCEL_SaveSheetTo_Access() As Boolean

Dim obj_newExcelApp  As New Excel.Application
Dim obj_newExcelBook As New Excel.Workbook
Dim obj_newWorkSheet As New Excel.Worksheet
Dim str_aryReadData(17) As String
Dim iii As Long, jjj As Long, kkk As Long
Dim obj_DataBase As DAO.Database
Dim obj_DataRecordGo As DAO.Recordset
obj_newExcelApp.Workbooks.Open "D:\保单续缴表_sz.xls"
Set obj_newExcelBook = obj_newExcelApp.Workbooks(1)
Set obj_newWorkSheet = obj_newExcelBook.Sheets(1)

kkk = obj_newWorkSheet.Rows.count
jjj = 1
Set obj_DataBase = CurrentDb()
Do While jjj < kkk
   jjj = jjj + 1
   For iii = 0 To 17
      str_aryReadData(iii) = Space(0)
   Next iii
   str_aryReadData(1) = Trim(obj_newWorkSheet.Cells(jjj, 1))
   str_aryReadData(2) = Trim(obj_newWorkSheet.Cells(jjj, 2))
   str_aryReadData(3) = Trim(obj_newWorkSheet.Cells(jjj, 3))
   str_aryReadData(4) = Trim(obj_newWorkSheet.Cells(jjj, 4))
   str_aryReadData(5) = Trim(obj_newWorkSheet.Cells(jjj, 5))
   str_aryReadData(6) = Trim(obj_newWorkSheet.Cells(jjj, 6))
   str_aryReadData(7) = Trim(obj_newWorkSheet.Cells(jjj, 7))
   str_aryReadData(8) = Trim(obj_newWorkSheet.Cells(jjj, 8))
   str_aryReadData(9) = Trim(obj_newWorkSheet.Cells(jjj, 9))
   str_aryReadData(10) = Trim(obj_newWorkSheet.Cells(jjj, 10))
   str_aryReadData(11) = Trim(obj_newWorkSheet.Cells(jjj, 11))
   str_aryReadData(12) = Trim(obj_newWorkSheet.Cells(jjj, 12))
   str_aryReadData(13) = Trim(obj_newWorkSheet.Cells(jjj, 13))
   str_aryReadData(14) = Trim(obj_newWorkSheet.Cells(jjj, 14))
   str_aryReadData(15) = Trim(obj_newWorkSheet.Cells(jjj, 15))
   str_aryReadData(16) = Trim(obj_newWorkSheet.Cells(jjj, 16))
   str_aryReadData(17) = Trim(obj_newWorkSheet.Cells(jjj, 17))

   If (Trim(str_aryReadData(1)) = Space(0)) And (Trim(str_aryReadData(2)) = Space(0)) And _
      (Trim(str_aryReadData(3)) = Space(0)) And (Trim(str_aryReadData(4)) = Space(0)) And _
      (Trim(str_aryReadData(5)) = Space(0)) Then
      Exit Do
   End If
   Set obj_DataRecordGo = obj_DataBase.OpenRecordset("保单续缴表_sz", dbOpenDynaset)
      obj_DataRecordGo.AddNew
      obj_DataRecordGo![渠道] = str_aryReadData(1)
      obj_DataRecordGo![生效日] = str_aryReadData(2)
      obj_DataRecordGo![电销员] = str_aryReadData(3)
      obj_DataRecordGo![保单号码] = str_aryReadData(4)
      obj_DataRecordGo![投保人] = str_aryReadData(5)
      obj_DataRecordGo![被保人] = str_aryReadData(6)
      obj_DataRecordGo![险种] = str_aryReadData(7)
      obj_DataRecordGo![缴费年限] = str_aryReadData(8)
      obj_DataRecordGo![缴费方式] = str_aryReadData(9)
      obj_DataRecordGo![每期保费] = str_aryReadData(10)
      obj_DataRecordGo![已缴次数] = str_aryReadData(11)
      obj_DataRecordGo![已缴保费] = str_aryReadData(12)
      obj_DataRecordGo![最近缴费日期] = str_aryReadData(13)
      obj_DataRecordGo![应缴未缴次数] = str_aryReadData(14)
      obj_DataRecordGo![应缴未缴保费] = str_aryReadData(15)
      obj_DataRecordGo![保单状态] = str_aryReadData(16)
      'obj_DataRecordGo![失效日期] = str_aryReadData(17)
      obj_DataRecordGo.Update
Loop
obj_DataBase.close
obj_newExcelBook.close
obj_newExcelApp.Workbooks.close
MsgBox "资料处理完成", vbOKOnly + vbInformation, "Message Dialog"
End Function

作者: SRONE 时间: 2009-3-20 10:51
谢谢指点，能否将的实例传给我借鉴一下吗？我的邮箱为：shu2008jy@126.com

欢迎光临 Office中国论坛/Access中国论坛 (http://www.office-cn.net/)