数据导入的问题？？？

[hjshen2001]

将数据从excel 导入到access中，要求是这样的，设置对话框，可以对excel和access文件按照路径进行选择，选择完毕，自动产生access的table的列表和excel的sheet的列表，分别选定具体内容以后，开始导入？？

最好有源代码

[阿建像熊猫]

Public Sub saveExcelInput()
With dlgExcelSave
.FileName = ""
.CancelError = True
.DialogTitle = "保存"
.Filter = "Excel数据文件|*.xls"
On Error GoTo aaa
.ShowSave
End With

If Dir(dlgExcelSave.FileName) <> "" Then

If MsgBox("¡°" & dlgExcelSave.FileName & "¡±ÎļþÒѾ­´æÔÚ£¬ÊÇ·ñ´ú»»£¿", 16 + vbYesNo, "ÌáÎÊ") = vbYes Then
Kill dlgExcelSave.FileName
Else
Exit Sub
End If

End If
Dim i As Integer
Dim exstring As String
Dim exConn As ADODB.Connection
Dim exRs As ADODB.Recordset
Dim exPath As String
Dim exName As String
Dim exPos As Integer

exPos = InStrRev(dlgExcelSave.FileName, "\")
exPath = Left(dlgExcelSave.FileName, exPos - 1)
exName = Right(dlgExcelSave.FileName, Len(dlgExcelSave.FileName) - exPos)


' exName = Left(dlgExcelSave.FileName ,)

Set exConn = New ADODB.Connection
Set exRs = New ADODB.Recordset

exConn.Open "Driver={Microsoft Excel Driver (*.xls)};UID=;PWD=;DBQ=" & exPath



For i = 0 To ListFieldPrint.ListCount - 1
exstring = exstring & ListFieldPrint.List(i) & " char(50) ,"
Next

exstring = Left(exstring, Len(exstring) - 1)
exConn.Execute "create table " & exName & "(" & exstring & ")"
exRs.Open "select * from " & exName, exConn, 2, 2

'''
Dim rs As ADODB.Recordset
Dim sql As String
Dim j As Integer
Set rs = New ADODB.Recordset
sql = "select * from " & sqlTable
conndbOpen
rs.Open sql, conn, 1, 1

If rs.RecordCount = 0 Then
MsgBox "ûÓÐÊý¾Ý£¬µ«Äܵ¼³öÊý¾Ý¿â½á¹¹£¡", 48, "Ìáʾ"
End If

ProgressExcel.Visible = True
ProgressExcel.Max = rs.RecordCount
If sqlTable = "Apparatus" Or sqlTable = "Consignment" Then '''µ±Ñ¡ÔñÁ˱íApparatus»òÕßConsignmentµÄʱºò
Do While Not rs.EOF
exRs.AddNew
For i = 0 To ListFieldPrint.ListCount - 1
If ListFieldPrint.List(i) = "Ê¡±àºÅ" Then '''»ñµÃÊ¡Ãû

Dim Prs As ADODB.Recordset
Dim Psql As String
Set Prs = New ADODB.Recordset
Psql = "select * from Province where Ê¡±àºÅ='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Prs.Open Psql, conn, 1, 1

If Not (Prs.BOF And Prs.EOF) Then
exRs.Fields(i).Value = Prs.Fields("Ê¡Ãû").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
ElseIf ListFieldPrint.List(i) = "ÊбàºÅ" Then '''»ñµÃ³ÇÊÐÃû

Dim Crs As ADODB.Recordset
Dim Csql As String
Set Crs = New ADODB.Recordset
Csql = "select * from City where ÊбàºÅ='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Crs.Open Csql, conn, 1, 1

If Not (Crs.BOF And Crs.EOF) Then
exRs.Fields(i).Value = Crs.Fields("ÊÐÃû").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If

ElseIf ListFieldPrint.List(i) = "µ¥Î»±àºÅ" Then '''»ñµÃµ¥Î»Ãû

Dim Srs As ADODB.Recordset
Dim Ssql As String
Set Srs = New ADODB.Recordset
Ssql = "select * from School where µ¥Î»´úÂë='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Srs.Open Ssql, conn, 1, 1

If Not (Srs.BOF And Srs.EOF) Then
exRs.Fields(i).Value = Srs.Fields("µ¥Î»").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If

Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If

Next
exRs.Update
j = j + 1
ProgressExcel.Value = j
rs.MoveNext
Loop
Else
Do While Not rs.EOF
exRs.AddNew
For i = 0 To ListFieldPrint.ListCount - 1
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
Next
exRs.Update
j = j + 1
ProgressExcel.Value = j
rs.MoveNext
Loop
End If
MsgBox "µ¼³öÍê³É£¡", 64, "Ìáʾ"
' ProgressExcel.Value = 0
'''
Prs.Close
Set Prs = Nothing
Crs.Close
Set Crs = Nothing
Srs.Close
Set Srs = Nothing
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
exRs.Close
Set exRs = Nothing
exConn.Close
Set exConn = Nothing
aaa:
' Exit Sub
End Sub

[rocllllll]

厉害,我头都晕了

[hjshen2001]

首先感谢jacksonjian，能稍微解释一下吗，我也看的头晕...

[feiqinfeiwhw]

Option Explicit
Private Const FeildCounts = 15
Private Const FeildCount = 28
Private Type FeildInfo
Col As Integer
End Type

Private Type ExcelInfo
Feilds(1 To FeildCounts) As FeildInfo
End Type
Private mStartRow As Long
Private mRowsCount As Long
Private eidCol As Integer


Public Function ImportKS(ByRef pcnnSvr As ADODB.Connection) As Boolean
'// 作 者：Colin Hans
'// 日 期：2003-07-28 21:22:55
Dim dlgTmp As Object
Dim exlTmp As Object
Dim mEInfo As ExcelInfo
Dim frmTmp As New FTime
' Dim tmpFrm As New frmQueKao
Dim lngRow As Long
Dim lngCol As Long
Dim strFile As String
Dim isOk As Boolean
Dim strYes As String
Dim strSql As String
Dim strKdCode As String
Dim iPos As Integer
Dim strName As String
Dim strBC As String
On Error GoTo PROC_ERR


'//Init Var
mStartRow = 0
mRowsCount = 0
Load frmTmp
Set dlgTmp = frmTmp.Cdlg

dlgTmp.InitDir = App.Path
dlgTmp.DialogTitle = "请选择导入的Excel文件!"
dlgTmp.Filter = "Excel文件(*.xls)|*.xls"
dlgTmp.ShowOpen
strFile = dlgTmp.FileName

Unload frmTmp


If Dir(strFile, vbNormal) = "" Then
MsgBox "无法找到指定的Excel文件，系统将中止操作。", _
vbCritical, "系统提示!"
GoTo PROC_ERR
End If

iPos = InStrRev(strFile, "\")
If iPos = 0 Then GoTo PROC_ERR
strKdCode = Right(strFile, Len(strFile) - iPos)

strName = Left(strKdCode, 2)

If strName = "缺考" Then
' Load tmpFrm
'
' tmpFrm.Show 1
'
' If Not tmpFrm.mIsok Then
' ImportKS = False
' Load tmpFrm
' Exit Function
' End If

strKdCode = mID(strKdCode, 3, Len(strKdCode))

iPos = InStr(1, strKdCode, "_")
If iPos = 0 Then GoTo PROC_ERR

strKdCode = Left(strKdCode, iPos - 1)

' strBC = tmpFrm.txtBc
Else
strBC = ""
End If

If strBC = "" Then
iPos = InStr(1, strKdCode, ".")
If iPos = 0 Then GoTo PROC_ERR
strKdCode = Left(strKdCode, iPos - 1)
If Len(strKdCode) < 1 Then GoTo PROC_ERR
End If

Set exlTmp = GetObject(strFile)
lngRow = GetColInfo(exlTmp, mEInfo, strBC)
If lngRow = 0 Then Exit Function
isOk = CopyExcelInfo(pcnnSvr, mEInfo, strKdCode, strBC, lngRow, exlTmp)
If Not isOk Then
MsgBox "复制Excel信息到服务器时出错，系统将中止操作。", _
vbCritical, "系统提示!"
GoTo PROC_ERR
End If

PROC_EXT:
ImportKS = True
Exit Function
PROC_ERR:
ImportKS = False
End Function

[feiqinfeiwhw]

Private Function GetColInfo(ByRef pObj As Object, _
ByRef pEInfo As ExcelInfo, ByVal strBC As String) As Integer
'// 作 者：Colin Hans
'// 日 期：2003-07-28 22:16:58
Dim strTmp As String
Dim lngTmp As Long
Dim lngCount As Long
Dim rstTmp As New ADODB.Recordset
Dim strSql As String
Dim isOk As Boolean
Dim strYes As String
Dim i As Integer
On Error GoTo PROC_ERR
For lngTmp = 1 To 255
strTmp = pObj.sheets(1).cells(lngTmp, 1)
If strBC = "" Then
If UCase(strTmp) = UCase("xh") Then
mStartRow = lngTmp + 1
Exit For
End If
Else
If UCase(strTmp) = UCase("Eid") Then
mStartRow = lngTmp + 1
Exit For
End If
End If
Next lngTmp

If mStartRow >= 255 Then GoTo PROC_ERR

For lngTmp = mStartRow To mStartRow + 32767
strTmp = pObj.sheets(1).cells(lngTmp, 4)
strTmp = Trim(strTmp)
If Len(strTmp) = 0 Then
mRowsCount = lngTmp - mStartRow
Exit For
End If
Next lngTmp
If lngTmp >= 32767 Then GoTo PROC_ERR
If lngTmp = mStartRow Then
GetColInfo = 0
Exit Function
End If

For lngTmp = 1 To FeildCount
strTmp = pObj.sheets(1).cells(mStartRow - 1, lngTmp)
Select Case UCase(strTmp)
Case Is = UCase("bmrq")
i = 6
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("xm")
i = 2
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("Name")
i = 2
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("sysno") '//eid
i = 1
pEInfo.Feilds(i).Col = lngTmp
eidCol = lngTmp
strTmp = pObj.sheets(1).cells(2, 4)
strSql = "select eid from examinee where eid='" & strTmp & "'"
isOk = mCommon.gcomnTmp.InitRecordset(rstTmp, strSql)
If Not isOk Then GoTo PROC_ERR
If rstTmp.RecordCount > 0 Then
strYes = MsgBox("该考点数据已经存在！是否要覆盖？", vbYesNo, "系统提示")
If strYes = vbNo Then
GetColInfo = 0
Exit Function
End If
End If
Case Is = UCase("Eid")
i = 1
pEInfo.Feilds(i).Col = lngTmp
eidCol = lngTmp
strTmp = pObj.sheets(1).cells(2, 1)
If strBC = pObj.sheets(1).cells(2, 10) Then
strSql = "select eid from examinee where eid='" & strTmp & "'"
isOk = mCommon.gcomnTmp.InitRecordset(rstTmp, strSql)
If Not isOk Then GoTo PROC_ERR
If rstTmp.RecordCount > 0 Then
strYes = MsgBox("该考点数据已经存在！是否要覆盖？", vbYesNo, "系统提示")
If strYes = vbNo Then
GetColInfo = 0
Exit Function
End If
End If
End If
Case Is = UCase("sfzh")
i = 5
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("dwmc")
i = 7
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("lxdh")
i = 8
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("bc")
i = 9
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("fdd2")
i = 15
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("kssj")
i = 15
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("shy")
i = 14
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("xl")
i = 12
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("kjzyzg")
i = 11
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("jxjynd")
i = 10
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("jxjylb")
i = 3
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("jxjyjb")
i = 4
pEInfo.Feilds(i).Col = lngTmp
Case Is = UCase("xzq")
i = 13
pEInfo.Feilds(i).Col = lngTmp
Case Else
End Select
Next lngTmp
PROC_EXT:
GetColInfo = mRowsCount
Exit Function
PROC_ERR:
GetColInfo = False
End Function

[feiqinfeiwhw]

Private Function CopyExcelInfo(ByRef pcnnSvr As ADODB.Connection, _
ByRef pEInfo As ExcelInfo, _
ByVal pKdCode As String, ByVal strBC As String, _
ByVal lngRow As Long, ByVal pObj As Object) As Boolean
'// 作 者：Colin Hans
'// 日 期：2003-07-29 00:55:31
Dim strSql As String
Dim strEID As String
Dim rstTmp As New ADODB.Recordset
Dim cmd As New ADODB.Command
Dim isOk As Boolean
Dim lngCount As Long
Dim lngTmp As Long
Dim lngTmp1 As Long
Dim lngCount1 As Long
Dim intpos As Integer
Dim k As Integer
Dim lngXh As Long

Dim prgTmp As Object
Dim strTmp As String
Dim pxdName As String
Dim strSfzh As String
Dim strLxdh As String

Dim strName As String
Dim strJxjylb As String
Dim strJxjyjb As String
Dim strDwmc As String
Dim strJxjynd As String
Dim strKjzyzg As String
Dim strXl As String
Dim strXzq As String
Dim strShy As String

Dim dtType As ADODB.DataTypeEnum

On Error GoTo PROC_ERR
Set prgTmp = CreateObject("Common.CProgressBar")
strSql = "Select * from Tester Where Testercode='" & _
pKdCode & "'"
isOk = InitRecordset(rstTmp, strSql, pcnnSvr)
If Not isOk Then GoTo PROC_ERR
Select Case rstTmp.RecordCount
Case Is = 0
MsgBox "请设置考点数据！", vbExclamation, "系统信息"
GoTo PROC_ERR
Case Is = 1
pxdName = rstTmp.Fields("Tester")
If MsgBox("是否删除以前导入的数据?", vbQuestion + vbYesNo, "系统信息!") = vbYes Then
pcnnSvr.Execute "Delete from Examinee Where ImportCode='" & pKdCode & "'"
End If
Case Else
pxdName = ""
End Select
rstTmp.Close

strSql = "select count(*) as SumNumber from examinee"
isOk = InitRecordset(rstTmp, strSql, pcnnSvr)
If Not isOk Then GoTo PROC_ERR
If rstTmp.RecordCount > 0 And Not IsNull(rstTmp.Fields("SumNumber")) And rstTmp.Fields("sumNumber") > 0 Then
lngXh = rstTmp.Fields("SumNumber") + 1
Else
lngXh = 1
End If
rstTmp.Close

If lngRow > 1 Then
prgTmp.Min = 0
prgTmp.Max = lngRow
prgTmp.Caption = " 正在复制Excel信息到服务器, 请稍候..."
prgTmp.Show
End If
For lngTmp = mStartRow To lngRow + 1 '
If Asc(Right(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(1).Col), 1)) = 255 Then
strEID = CStr(Left(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(1).Col)), _
Len(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(1).Col))) - 1))
Else
strEID = CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(1).Col))
End If
strSql = "Select * from Examinee Where EID='" & _
strEID & "'"
isOk = InitRecordset(rstTmp, strSql, pcnnSvr)
If Not isOk Then GoTo PROC_ERR
If rstTmp.RecordCount < 1 Then rstTmp.AddNew
k = Int(Rnd * 100)
rstTmp.Fields("ordid") = k
rstTmp.Fields("EID") = strEID
strName = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(2).Col)
rstTmp.Fields("name") = strName
strJxjylb = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(3).Col)
rstTmp.Fields("jxjylb") = strJxjylb
strJxjyjb = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(4).Col)
rstTmp.Fields("jxjyjb") = strJxjyjb

If Asc(Right(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(5).Col)), 1)) = 255 Then
strSfzh = CStr(Left(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(5).Col)), _
Len(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(5).Col))) - 1))
Else
strSfzh = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(5).Col)
End If
rstTmp.Fields("sfzh") = strSfzh
rstTmp.Fields("bmrq") = CDate(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(6).Col))
strDwmc = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(7).Col)
rstTmp.Fields("dwmc") = strDwmc
If Asc(Right(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(8).Col)), 1)) = 255 Then
strLxdh = CStr(Left(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(8).Col)), _
Len(CStr(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(8).Col))) - 1))
Else
strLxdh = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(8).Col)
End If
rstTmp.Fields("lxdh") = strLxdh
If strBC = "" Then
strBC = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(9).Col)
rstTmp.Fields("bc") = strBC
Else
rstTmp.Fields("bc") = strBC
End If
strJxjynd = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(10).Col)
rstTmp.Fields("jxjynd") = strJxjynd
strKjzyzg = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(11).Col)
rstTmp.Fields("kjzyzg") = strKjzyzg
strXl = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(12).Col)
rstTmp.Fields("xl") = strXl
strXzq = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(13).Col)
rstTmp.Fields("xzq") = strXzq
strShy = pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(14).Col)
rstTmp.Fields("shy") = strShy
rstTmp.Fields("kssj") = CInt(pObj.sheets(1).cells(lngTmp, pEInfo.Feilds(15).Col))
rstTmp.Fields("ssKdCode") = pKdCode
rstTmp.Fields("importCode") = pKdCode
rstTmp.Fields("importKssj") = rstTmp.Fields("kssj")
rstTmp.Fields("pxdName") = pxdName
rstTmp.Fields("Status") = 0
rstTmp.Fields("Alloted") = False
rstTmp.Fields("testNo") = Null
rstTmp.Fields("StatusDesc") = "未开考"
rstTmp.Fields("xh") = lngXh
lngXh = lngXh + 1
rstTmp.Update
rstTmp.Close
If lngRow > 1 Then prgTmp.Value = lngTmp
Next lngTmp


PROC_EXT:
If lngRow > 1 Then prgTmp.Hide
MsgBox "成功导入 " & lngRow & " 条考生信息！", vbInformation + vbOKOnly, _
"系统提示!"
CopyExcelInfo = True

strSql = "Select * from TestSetup Where TesterCode='" & pKdCode & "'"
isOk = InitRecordset(rstTmp, strSql, pcnnSvr)
If isOk Then
If rstTmp.RecordCount >= 1 Then
If MsgBox("该考点的场次信息已存在，是否删除此场次信息?", vbQuestion + vbYesNo) = vbYes Then
strSql = "Delete from TestSetup Where TesterCode='" & pKdCode & "'"
pcnnSvr.Execute strSql
End If
End If
End If
Exit Function
PROC_ERR:
CopyExcelInfo = False
End Function
Private Function InitRecordset(ByRef rstTmp As ADODB.Recordset, ByVal strSql As String, _
ByRef mcnnObj As ADODB.Connection) As Boolean
On Error GoTo PROC_ERR

With rstTmp
Set .ActiveConnection = mcnnObj
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open strSql
End With
PROC_EXT:
InitRecordset = True
Exit Function
PROC_ERR:
InitRecordset = False
End Function

[j4sxw]

晕呀

[hjshen2001]

lihonggen0
现在关键是问你table/sheet如何显示在combo box列表中

[lihonggen0]

将EXCEL表的数据导入到ACESS的函数代码怎么写,要求acess,excel的路径和表名都为变量?
---------------------------------------------------------------


如何將 Excel 的文件导入 Access文件？

　


引用DAO 3.6

下面我已將程序代码做成模块，只要导入必要之参数即可！

此一模块共有四个参数：
1、sSheetName：要导出资料的文件名称 (Sheet name)，例如 Sheet1
2、sExcelPath：要导出资料的 Excel 档案路径名称 (Workbook path)，例如 C:\book1.xls
3、sAccessTable：要导入的 Access Table 名称，例如 TestTable
4、sAccessDBPath：要导入的 Access 档案路径名称，例如 C:\Test.mdb

在声明中加入以下：

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"

[hjshen2001]

lihonggen0
要求acess,excel的路径和表名都为变量,不是固定路径下的*.mdb/*.xls

选中*.mdb/*.xls以后，利用combo box分别对table/sheet进行列表，再次选中具体的table/sheet以后，开始导入

[lihonggen0]

是呀！上面哪个过程允许你传参数呀！