Excel数据导入Access，导入不完全
If fso.FileExists(DataBase_Name_Connect_Info) = True Then
'基本信息数据库
l = 0
Set WIS_Conn = New ADODB.Connection
WIS_Conn.Open "provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DataBase_Name_Connect_Info & ";Persist Security Info=false"
Set WIS_Rs = WIS_Conn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, Empty))
ReDim tem_Arr(100)
Do Until WIS_Rs.EOF
If Left(WIS_Rs!table_name, 4) <> "MSys" Then
tem_Arr(l) = WIS_Rs!table_name
l = l + 1
End If
WIS_Rs.MoveNext
DoEvents
Loop
'MsgBox l
e = 0
frm_DB_CreateFile.txt_BS.Text = Format(Time, "hh:mm:ss") & " 获取Con数据库名称集合: " & l & vbCrLf & frm_DB_CreateFile.txt_BS.Text 'DataBase_Name_Connect_Info
DoEvents
'Call Close_DB
' If WIS_Rs.State = adStateOpen Then WIS_Rs.Close
' Set WIS_Rs = Nothing
' If WIS_Conn.State = adStateOpen Then WIS_Conn.Close
' Set WIS_Conn = Nothing
For k = 0 To l - 1 'DB_Table 名称集合
If l = 0 Then
Exit For
End If
If Judge_Arr(Arr_Sheet(), tem_Arr(k)) = True Then '判断该表是否存在 Excel Sheet中
Excel_Search_TxT = "select * from [" & tem_Arr(k) & "$]" 'Excel
Set Excel_Rs = Excel_Connect(Excel_Search_TxT, str_Excel_Addr)
Int_Excel_Count = Excel_Rs.RecordCount '表示Excel 数据个数
' DoEvents
'lab_Progree & Arr_Sheet_DB_Count(k)
frm_DB_CreateFile.txt_BS.Text = Format(Time, "hh:mm:ss") & " 载入Con数据: " & tem_Arr(k) & " Count:" & " @:" & Int_Excel_Count & vbCrLf & frm_DB_CreateFile.txt_BS.Text 'DataBase_Name_Connect_Info
' If tem_Arr(k) = "Case_Notice" Then
' MsgBox 4
' End If
tem_DB_Count = 0
If Int_Excel_Count <> 0 Then
w = 0
'If str_Update_Mode = "N" Then '表示采用的全新数据，将删除 数据库里面的数据
' DB_Delete_TxT = "Delete * from " & tem_Arr(k) 'Access
' str_access_sql = str_DB_Provider & DataBase_Name_Connect_Info & ";Jet OLEDB:Database Password=" & WIS_DB_PD '包含有密码
' 'WIS_Conn.Open str_access_sql
' WIS_Conn.Execute DB_Delete_TxT
DoEvents
DB_Search_TxT = "Select * from " & tem_Arr(k) 'Access '表示仅仅增加新的数据 不删除旧数据
Set DB_Rs = WIS_Connect(DB_Search_TxT, "Record_Info", DataBase_Type)
Int_Field_Count = DB_Rs.Fields.Count '表示字段个数
DoEvents
Set X_Sheet = X_Book.Worksheets(tem_Arr(k)) '开始操作 选定的 Sheet-》对应表名
X_Sheet.Activate
'
'Excel_Rs.MoveFirst
i = 0
ReDim Arr_Field(Int_Field_Count - 1) '获取 字段名
For Each str_Field In DB_Rs.Fields
' If Not IsNull(str_Field.Value) Then
Arr_Field(i) = str_Field.Name
' End If
i = i + 1
Next
DoEvents
For i = 0 To Int_Excel_Count - 1
' If i = 94 Then
' i = 94
' End If
DB_Rs.AddNew
For j = 0 To Int_Field_Count - 1
If X_Sheet.Cells(2 + i, j + 1) = "" Or IsNull(X_Sheet.Cells(2 + i, j + 1)) = True Then
Else
DB_Rs.Fields(Arr_Field(j)).Value = X_Sheet.Cells(2 + i, j + 1)
End If
Next
DB_Rs.Update
If Int_Excel_Count > 1 Then
DB_Rs.MoveNext
End If
DoEvents
frm_DB_CreateFile.cmd_Restore.Caption = Format(((i + 1) / (Int_Excel_Count)) * 100, "00.0") & "%"
Next
tem_DB_Count = DB_Rs.RecordCount
If Int_Excel_Count <> tem_DB_Count Then
frm_DB_CreateFile.txt_BS.Text = Format(Time, "hh:mm:ss") & " 载入Con数据:=> " & tem_Arr(k) & " Fail:DB_Count:" & tem_DB_Count & ",Exc._Count:" & Int_Excel_Count & vbCrLf & frm_DB_CreateFile.txt_BS.Text 'DataBase_Name_Connect_Info
e = e + 1
End If
End If
End If
'MsgBox k
Next
Else
frm_DB_CreateFile.txt_BS.Text = Format(Time, "hh:mm:ss") & " 载入Con数据,Fail To Load DB:" & DataBase_Name_Connect_Info & vbCrLf & frm_DB_CreateFile.txt_BS.Text 'DataBase_Name_Connect_Info
End If
For i = 0 To Int_Excel_Count - 1
' If i = 94 Then
' i = 94
' End If
DB_Rs.AddNew
For j = 0 To Int_Field_Count - 1
If X_Sheet.Cells(2 + i, j + 1) = "" Or IsNull(X_Sheet.Cells(2 + i, j + 1)) = True Then
Else
DB_Rs.Fields(Arr_Field(j)).Value = X_Sheet.Cells(2 + i, j + 1)
End If
Next
DB_Rs.Update
If Int_Excel_Count > 1 Then
DB_Rs.MoveNext
End If
DoEvents
frm_DB_CreateFile.cmd_Restore.Caption = Format(((i + 1) / (Int_Excel_Count)) * 100, "00.0") & "%"
Next
以上是将Excell中的数据导入到Access中。但有时发现只能导入部分数据，比如有3000多条数据有时只能导入1000多点...不知道哪里需要完善下。各位帮忙看看呢... ACCESS和EXCEL相互导入导出最快速的方发是使用ACCESS对象的DOCMD对象的内置方法.
此方法等同于在access程序中菜单中选择导入和导出excel表格.
access对象导入excel文件到mdb: AccAPP.DoCmd.TransferDatabase
access对象导出数据库到excel: AccAPP.DoCmd.OutputTo
具体参数自行网上查询一下吧. 参考: http://msdn.microsoft.com/zh-cn/library/jj249889.aspx 把 Excel 当作外部数据库来查询。下面是早先 DAO 的例子，你可以改为 ADO 的：
Private Sub ExportExcelSheetToAccess(sSheetName As String, sExcelPath As String, sAccessTable As String, sAccessDBPath As String)
Dim db As Database
Dim rs As Recordset
Set db = OpenDatabase(sExcelPath, True, False, "Excel 5.0")
Call db.Execute("Select * into [;database=" & sAccessDBPath & "]." & sAccessTable & " FROM [" & sSheetName & "$]")
MsgBox "Table exported successfully.", vbInformation, "Yams"
End Sub
使用范例如下：將 C:\book1.xls 中的 Sheet1 导入 C:\Test.mdb 成为 TestTable
ExportExcelSheetToAccess "Sheet1", "C:\book1.xls", "TestTable", "C:\Test.mdb"
Dim temSet As ADODB.Recordset
Dim temCon As ADODB.Connection
Dim i, k As Integer
Dim tem_Arr(200) As String
Dim tem_Arr_DB(200) As String
Dim fso As New FileSystemObject
Int_DB_Con_Table_Count = 0
Int_DB_Rec_Table_Count = 0
Int_DB_Log_Table_Count = 0
If fso.FileExists(DataBase_Name_Connect_Info) = True Then
i = 0
Set temCon = New ADODB.Connection
temCon.Open "provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DataBase_Name_Connect_Info & ";Persist Security Info=false"
Set temSet = temCon.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, Empty))
Do Until temSet.EOF
If Left(temSet!table_name, 4) <> "MSys" Then
tem_Arr(i) = temSet!table_name
tem_Arr_DB(i) = "Record_Info" 'Record_History
i = i + 1
End If
temSet.MoveNext
Loop
Int_DB_Con_Table_Count = i
DoEvents
txt_BS.Text = "获取数据库Con 表名集合, Count:" & Int_DB_Con_Table_Count & vbCrLf & txt_BS.Text
DoEvents
' For i = 0 To Int_Load_DB_Table_Count - 1
' DB_BackUp_Con_Table(i) = tem_Arr(i) '获取 Con 数据库的表名集合
' Next
End If
If fso.FileExists(DataBase_Name_Connect_Record) = True Then
Set temCon = New ADODB.Connection
temCon.Open "provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DataBase_Name_Connect_Record & ";Persist Security Info=false"
Set temSet = temCon.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, Empty))
Do Until temSet.EOF
If Left(temSet!table_name, 4) <> "MSys" Then
tem_Arr(i) = temSet!table_name
tem_Arr_DB(i) = "Record_History" 'Record_History
i = i + 1
End If
temSet.MoveNext
Loop
Int_DB_Rec_Table_Count = i - Int_DB_Con_Table_Count
DoEvents
txt_BS.Text = "获取数据库Rec 表名集合, Count:" & Int_DB_Rec_Table_Count & vbCrLf & txt_BS.Text
End If
If fso.FileExists(DataBase_Name_Connect_Log) = True Then
Set temCon = New ADODB.Connection
temCon.Open "provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DataBase_Name_Connect_Log & ";Persist Security Info=false"
Set temSet = temCon.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, Empty))
Do Until temSet.EOF
If Left(temSet!table_name, 4) <> "MSys" Then
tem_Arr(i) = temSet!table_name
tem_Arr_DB(i) = "Record_History" 'Record_History
i = i + 1
End If
temSet.MoveNext
Loop
Int_DB_Log_Table_Count = i - Int_DB_Rec_Table_Count
DoEvents
txt_BS.Text = "获取数据库Log 表名集合, Count:" & Int_DB_Log_Table_Count & vbCrLf & txt_BS.Text
' ReDim DB_BackUp_Log_Table(Int_Load_DB_Table_Count - 1)
' For i = 0 To Int_Load_DB_Table_Count - 1
' DB_BackUp_Log_Table(i) = tem_Arr(i) '获取 Rec 数据库的表名集合
' Next
End If
If Int_DB_Con_Table_Count = 0 And Int_DB_Rec_Table_Count = 0 And Int_DB_Log_Table_Count = 0 Then
Exit Sub
End If
ReDim DB_BackUp_Table(i)
ReDim DB_BackUp_Table_DB(i - 1)
For k = 0 To i - 1
DB_BackUp_Table(k) = tem_Arr(k) '获取 Rec 数据库的表名集合
DB_BackUp_Table_DB(k) = tem_Arr_DB(k) 'Info/History
'MsgBox tem_Arr(k)
Next
DB_BackUp_Table(i) = "Summary"
If fso.FolderExists(App.Path & "\BackUp\") = False Then
fso.CreateFolder (App.Path & "\BackUp\")
End If
DB_BackUp_File_Addr = App.Path & "\BackUp\Con_" & Format(Now, "yyyymmddhhmmss") & ".xls"
'dd hh:mm:ss
txt_BS.Text = "获取备份数据File地址" & vbCrLf & txt_BS.Text
Access to excel采用的以上的，不知道比起AccAPP.DoCmd.OutputTo哪种好呢？
补充：VB , 数据库(包含打印，安装，报表)
