很简单的问题，如何将EXCEL中的数据转换到ACCESS2000中，需源程序（一）

[yijn]

以下每提供一项帮助得分100分（如果程序好的话分数是没有问题的）
1、ACCESS2000必须用ADO调用，例子程序中ACCESS2000数据库尽量复杂一点，并写出如何写数据库各字段部分，还有必须。
2、EXCEL中的表格不规则，有空行或数据总结行，不能一起导入，需逐行判断然后导入。
3、需要EXCEL表格的可以MAIL索取，MAIL：[e-mail]。源程序也可发往该邮箱！谢谢！
如能协助完全解决问题将提供1000分以上！

[网络咖啡]

Option Explicit
Private CnProduct As New ADODB.Connection '产品数据库的连接
Private CnAllData As New ADODB.Connection '产品板数据库的连接（全数据存储）
Private RtProduct As New ADODB.Recordset '产品数据库的记录集
Private RtAllData As New ADODB.Recordset '产品板数据库的记录集（全数据存储）

Dim sModel(1 To 60) As String '产品规格数组

'该函数实现程序控制的数据库连接，即由程序指定连接哪个数据库
Private Function Connect(sPath As String, iFlag As Integer) As Boolean
'连接数据库，获得记录集
CnProduct.ConnectionString = "Provider= Microsoft.Jet.OLEDB.4.0"
CnAllData.ConnectionString = "Provider= Microsoft.Jet.OLEDB.4.0"
'sPath存储数据库的相对路径，如"\数据库\Model.mdb"
'存储连接数据库的类型，1表示连接产品数据库，否则连接全数据存储数据库
If iFlag = 1 Then
CnProduct.Open App.Path & sPath
RtProduct.ActiveConnection = CnProduct
Else
CnAllData.Open App.Path & sPath
RtAllData.ActiveConnection = CnAllData
End If
Connect = True
End Function

'用于插入产品数据库
Public Function InsertProduct(sNo As String, Bresult As Byte, lQuality As Currency, Lmin As Single, Lave As Single, Lmax As Single, Mmin As Single, Mave As Single, Mmax As Single, Rmin As Single, Rave As Single, Rmax As Single, Pizhong As Single) As Boolean
'sNo存储产品编号，长度为13
'bResult存储测试结果
'lQuality产品质量
'Lmax,Iave,Lmin分别存储左路数据的最大值、平均值、最小值
'Mmax,Mave,Mmin分别存储中路数据的最大值、平均值、最小值
'Rmax,Rave,Rmin分别存储右路数据的最大值、平均值、最小值
'Pizhong存储料重
Dim sTemp As String '存储日期字符串
'插入数据库

Connect "\日\" & Mid(sNo, 1, 4) & ".mdb", 1
RtProduct.Open "Product", CnProduct, adOpenDynamic, adLockPessimistic
'添加到数据库
RtProduct.AddNew
RtProduct.Fields(0) = sNo

'测试结果
RtProduct.Fields(1) = Bresult

'产品质量
RtProduct.Fields(2) = Format(lQuality, "###0.00")

'左路测试数据
RtProduct.Fields(3) = Format(Lmin, "###0.00")
RtProduct.Fields(4) = Format(Lave, "###0.00")
RtProduct.Fields(5) = Format(Lmax, "###0.00")

'中路测试数据
RtProduct.Fields(6) = Format(Mmin, "###0.00")
RtProduct.Fields(7) = Format(Mave, "###0.00")
RtProduct.Fields(8) = Format(Mmax, "###0.00")

'右路测试数据
RtProduct.Fields(9) = Format(Rmin, "###0.00")
RtProduct.Fields(10) = Format(Rave, "###0.00")
RtProduct.Fields(11) = Format(Rmax, "###0.00")

'坯重
RtProduct.Fields(12) = Format(Pizhong, "###0.00")

RtProduct.Update

'关闭连接对象
CnProduct.Close

InsertProduct = True '操作成功，返回True

End Function

'用于插入全数据存储的数据库
Public Function InsertAllData(L() As Single, M() As Single, R() As Single) As Boolean
'L()存储左路测试数据
'M()存储中路测试数据
'R()存储右路测试数据

Dim i As Integer '循环变量
i = 1
Connect "\AllData\Data.mdb", 0
RtAllData.Open "Data", CnAllData, adOpenDynamic, adLockPessimistic
'插入全数据存储数据库
While (i < UBound(L()) + 1)
RtAllData.AddNew

RtAllData.Fields(0) = Format(L(i), "###0.00")
RtAllData.Fields(1) = Format(M(i), "###0.00")
RtAllData.Fields(2) = Format(R(i), "###0.00")

RtAllData.Update
i = i + 1
Wend

CnAllData.Close
InsertAllData = True '操作成功返回True
End Function

'处理日期字段，如：01-8-10转换为010810
Private Function DateString() As String
Dim CurrentDate As Date
Dim str() As String '用于处理的字符串
Dim i As Integer '循环变量
Dim str1 As String '用于处理日期字符串
CurrentDate = Date '获得当前的日期，格式如：01-8-10

str1 = CStr(CurrentDate)
str = Split(str1, "-")
For i = 0 To 2
If (Len(str(i)) = 1) Then str(i) = "0" & str(i) '处理日期字符串，8转换为08
Next
DateString = str(0) & str(1) & str(2) '返回处理后的字符串
End Function

'创建数据库，sPath是路径和全名，如："\日\010821.mdb"
Public Function Creatdatabase(sPath As String) As Boolean
If (Dir(App.Path & "\日\*.mdb") <> "") Then
Kill App.Path & "\日\*.mdb" '清空日数据库文件夹
End If
'创建日数据库文件
FileCopy App.Path & "\DataBase\Model.mdb", App.Path & sPath
Creatdatabase = True '操作成功返回True
End Function

Public Function ClearAllData()
Connect "\AllData\Data.mdb", 0
CnAllData.Execute "delete * from Data"
CnAllData.Close
End Function

Public Function ClearProduct()
Connect "\DataBase\Model.mdb", 1
CnProduct.Execute "delete * from Product"
CnProduct.Close
End Function

[网络咖啡]

'实现一天的班查询
Private Function SearchBan(sDate As String, iBan As Integer, iBanSearchN0() As Integer, iBanSearchN1() As Integer, iBanSearchN2() As Integer, lBanSearchQ0() As Single, lBanSearchQ1() As Single, lBanSearchQ2() As Single, lTouliao0() As Single, lTouliao1() As Single, lTouliao2() As Single)
'sDate是查询的日期，格式为0104或者010402
'iBan是班次，分别为1，2，3
'iBanSearchN0为合格品个数，iBanSearchN1为待磨品个数，
'iBanSearchN2为残缺品个数
'lBanSearchQ0为合格品总质量，lBanSearchQ1为待磨品总质量
'lBanSearch2为残缺品的总质量
'lTouliao0为合格品投料总质量，lTouliao1为待磨品投料总质量
'lTouliao2为残缺品的投料总质量

Dim i As Integer '循环变量
'查询数据库
RtProduct.Open "select 产品编号,测试结果,产品质量,料重 from Product where 产品编号 like " & "'" & sDate & "%'"
'便历返回的记录集进行查询和统计
While (RtProduct.EOF <> True)
'检查是否是要检查的班次
If (Mid(RtProduct(0), 7, 1) = CStr(iBan)) Then
'与规格数组进行比较，并在相应的对象上统计
For i = 1 To 60
If (Mid(RtProduct(0), 12, 2) = sModel(i)) Then
If (RtProduct(1) = 1) Then
iBanSearchN0(i) = iBanSearchN0(i) + 1 '合格品个数加1
lBanSearchQ0(i) = lBanSearchQ0(i) + RtProduct(2) '合格品质量累加
lTouliao0(i) = lTouliao0(i) + RtProduct(3) '合格品投料质量累加
ElseIf (RtProduct(1) = 2) Then
iBanSearchN1(i) = iBanSearchN1(i) + 1 '待磨品个数加1
lBanSearchQ1(i) = lBanSearchQ1(i) + RtProduct(2) '待磨品质量累加
lTouliao1(i) = lTouliao1(i) + RtProduct(3) '待磨品投料质量累加
Else
iBanSearchN2(i) = iBanSearchN2(i) + 1 '残缺品个数加1
lBanSearchQ2(i) = lBanSearchQ2(i) + RtProduct(2) '残缺品质量累加
lTouliao2(i) = lTouliao2(i) + RtProduct(3) '残缺品投料质量累加
End If
End If
Next i
End If
RtProduct.MoveNext '指向下一条记录
Wend
RtProduct.Close
End Function

'实现按班次检索，sDate是日期（可以是月份，也可以是日期），iBan是班次
Public Function SearchbyBan(sDate As String, iBan As Integer, _
iBanSearchN0() As Integer, iBanSearchN1() As Integer, _
iBanSearchN2() As Integer, lBanSearchQ0() As Single, _
lBanSearchQ1() As Single, lBanSearchQ2() As Single, lTouliao0() As Single, lTouliao1() As Single, lTouliao2() As Single)
'iBanSearchN0为合格品个数，iBanSearchN1为待磨品个数，
'iBanSearchN2为残缺品个数
'lBanSearchQ0为合格品总质量，lBanSearchQ1为待磨品总质量
'lBanSearch2为残缺品的总质量
'lTouliao0为合格品投料总质量，lTouliao1为待磨品投料总质量
'lTouliao2为残缺品的投料总质量

Dim i As Integer '循环变量
'初始化结果数据
For i = 1 To 60
iBanSearchN0(i) = 0
iBanSearchN1(i) = 0
iBanSearchN2(i) = 0
lBanSearchQ0(i) = 0
lBanSearchQ1(i) = 0
lBanSearchQ2(i) = 0
Next i

'初始化规格数组
SearchInit

Connect "\日\" & Mid(sDate, 1, 4) & ".mdb", 1
'把月份的查询转化为日期的查询，缩小返回的记录集对象，提高查询效率
'日期长度为4，表示要查询的是月份，转化为对日期的查询
If (Len(sDate) = 4) Then
For i = 1 To 31
If (i < 10) Then
SearchBan sDate & "0" & i, iBan, iBanSearchN0, iBanSearchN1, iBanSearchN2, lBanSearchQ0, lBanSearchQ1, lBanSearchQ2, lTouliao0, lTouliao1, lTouliao2
Else
SearchBan sDate & i, iBan, iBanSearchN0, iBanSearchN1, iBanSearchN2, lBanSearchQ0, lBanSearchQ1, lBanSearchQ2, lTouliao0, lTouliao1, lTouliao2
End If
Next i
'日期的长度是6，表示是对日期的查询，直接查询
ElseIf (Len(sDate) = 6) Then
SearchBan sDate, iBan, iBanSearchN0, iBanSearchN1, iBanSearchN2, lBanSearchQ0, lBanSearchQ1, lBanSearchQ2, lTouliao0, lTouliao1, lTouliao2
'否则是日期格式错误
Else
MsgBox "日期格式错误！", , "警告"
End If
CnProduct.Close
End Function

'实现一天的检索
Private Function SearchDay(sDate As String, iBanSearchN0() As Integer, iBanSearchN1() As Integer, iBanSearchN2() As Integer, lBanSearchQ0() As Single, lBanSearchQ1() As Single, lBanSearchQ2() As Single, lTouliao0() As Single, lTouliao1() As Single, lTouliao2() As Single)
'sDate是查询的日期
'iBanSearchN0为合格品个数，iBanSearchN1为待磨品个数，
'iBanSearchN2为残缺品个数
'lBanSearchQ0为合格品总质量，lBanSearchQ1为待磨品总质量
'lBanSearch2为残缺品的总质量
'lTouliao0为合格品投料总质量，lTouliao1为待磨品投料总质量
'lTouliao2为残缺品的投料总质量

Dim i As Integer '循环变量
Dim str As String
str = "select 产品编号,测试结果,产品质量,料重 from Product where 产品编号 like " & "'" & sDate & "%'"
Debug.Print str
RtProduct.Open str
While (RtProduct.EOF <> True)
For i = 1 To 60
If (Mid(RtProduct(0), 12, 2) = sModel(i)) Then
If (RtProduct(1) = 1) Then
iBanSearchN0(i) = iBanSearchN0(i) + 1 '合格品个数加1
lBanSearchQ0(i) = lBanSearchQ0(i) + RtProduct(2) '合格品质量累加
lTouliao0(i) = lTouliao0(i) + RtProduct(3) '合格品投料质量累加
ElseIf (RtProduct(1) = 2) Then
iBanSearchN1(i) = iBanSearchN1(i) + 1 '待磨品个数加1
lBanSearchQ1(i) = lBanSearchQ1(i) + RtProduct(2) '待磨品质量累加
lTouliao1(i) = lTouliao1(i) + RtProduct(3) '待磨品投料质量累加
Else
iBanSearchN2(i) = iBanSearchN2(i) + 1 '残缺品个数加1
lBanSearchQ2(i) = lBanSearchQ2(i) + RtProduct(2) '残缺品质量累加
lTouliao2(i) = lTouliao2(i) + RtProduct(3) '残缺品投料质量累加
End If
End If
Next i
RtProduct.MoveNext '指向下一条记录
Wend
RtProduct.Close
End Function


'实现日期的检索
Public Sub SearchByDay(sDate As String, iBanSearchN0() As Integer, iBanSearchN1() As Integer, iBanSearchN2() As Integer, lBanSearchQ0() As Single, lBanSearchQ1() As Single, lBanSearchQ2() As Single, lTouliao0() As Single, lTouliao1() As Single, lTouliao2() As Single)
'sDate是要查询的日期
'iBanSearchN0为合格品个数，iBanSearchN1为待磨品个数，
'iBanSearchN2为残缺品个数
'lBanSearchQ0为合格品总质量，lBanSearchQ1为待磨品总质量
'lBanSearch2为残缺品的总质量
'lTouliao0为合格品投料总质量，lTouliao1为待磨品投料总质量
'lTouliao2为残缺品的投料总质量

Dim i As Integer '循环变量
'初始化结果数据
'For i = 1 To 60
' iBanSearchN0(i) = 0
' iBanSearchN1(i) = 0
' iBanSearchN2(i) = 0
' lBanSearchQ0(i) = 0
' lBanSearchQ1(i) = 0
' lBanSearchQ2(i) = 0
' Next i

'初始化规格数组
SearchInit

Connect "\日\" & Mid(sDate, 1, 4) & ".mdb", 1

If (Len(sDate) = 4) Then
For i = 1 To 31
If (i < 10) Then
SearchDay sDate & "0" & i, iBanSearchN0, iBanSearchN1, iBanSearchN2, lBanSearchQ0, lBanSearchQ1, lBanSearchQ2, lTouliao0, lTouliao1, lTouliao2
Else
SearchDay sDate & i, iBanSearchN0, iBanSearchN1, iBanSearchN2, lBanSearchQ0, lBanSearchQ1, lBanSearchQ2, lTouliao0, lTouliao1, lTouliao2
End If
Next i
ElseIf (Len(sDate) = 6) Then
SearchDay sDate, iBanSearchN0, iBanSearchN1, iBanSearchN2, lBanSearchQ0, lBanSearchQ1, lBanSearchQ2, lTouliao0, lTouliao1, lTouliao2
Else
MsgBox "日期格式错误！"
End If
C

[网络咖啡]

2、使用VBA创建一个EXCEL对象，依次读取每个cell的内容，然后判断，处理

[yijn]

你的程序很好，但能否说一下如何将EXCEL2000中的数据写入，而不是只是贴一个很好但与问题不一致的源代码。相当感谢！会另开一个帖子给分你的！

[tony_jian]

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

此一模块共有四个参数：
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"

[tony_jian]

---- 部分窗体及源程序代码如下：

---- 1．程序主模块

---- 定义Excel、Access对象变量，显示系统启动画面，进入系统主程序界面。强调一下，在编写程序之前须加入对Excel及Access库函数的引用，具体操作是：选择菜单栏'工程'\'引用…'，将'可使用的引用'列表框内'Microsoft Access 8.0 Object Library'和 'Microsoft Excel 8.0 Object Library'两项前的复选框标为选中，按"确定"返回。

mdsMain.bas
'定义数据库记录集及Excel对象变量
Public ex As New Excel.Application
Public exwbook As Excel.Workbook
Public exsheet As Excel.Worksheet
Public mydatabase As Database
Public myrecordset1 As Recordset
[定义记录集]
……
……
Public Opt As Integer '报表选项
[Opt为frmSelreport.frm返回值]
Public isYN As Boolean
Sub Main()
Load frmSplash
frmSplash.Show
frmSplash.Label2.Caption =
" 系统正在加载Access数据库..."
　　Set mydatabase = OpenDatabase("c:\sbda\sbda.mdb")
Set myrecordset1 = mydatabase.OpenRecordset
("报表打印(一)")
[此处对记录集赋值]
　　……
　　……
frmSplash.Label2.Caption =
" 系统正在加载Excel电子表格..."
Set ex = CreateObject("excel.application")
Set exwbook = ex.Workbooks.Open("c:\sbda\sbda.xls")
Load FrmInput　　　 '将数据输入窗体加载到内存中
Unload frmSplash
Load FrmMain　　　　'将主程序界面加载到内存中
End Sub

---- 2．报表打印模块
---- 其中ExcelDoForVB1()是一子程序，由prnProess()调用，作用是从Access中提取所需数据资料，填入Excel对应工作表（Worksheet）的相应单元格（Cells）中，然后打印已填入数据的表格；prnProess()则负责实现对VB通用对话框（Commom Dialog）中打印功能的控制。

mdlPrint.bas
Option Explicit
'定义循环计数变量
Public nRow As Integer, nCol As
Integer, nBtoE As Integer
'定义变量接收打印对话框返回值
Public BeginPage, EndPage, NumCopies
'程序运行时需进行判断的各种标志
Public nflag, Flag, ifNum
'数据记录集中指针移动数
Public PageN As Integer, n As Integer
'bar1为进度条
Public bar1 As Object

Sub prnProess()　　　　　　
'控制通用对话框打印功能
　　Set bar1 = FrmPrint.PgsBar1　'进度条
　　On Error GoTo errhandle:
　　If Flag = 0 Then　　　'当打印对话框中选"全部"时
　　　　Select Case Opt　　'选择需要打印的表格
　　　　　　Case 1
　　　　　　　　nflag = 1
　　　　　　　　myrecordset1.MoveFirst
　　　　　　　　myrecordset1.MovePrevious
　　　　　　　　PageN = 1
　　　　　　　　Do While nflag = 1
　　　　　　　　　　Call ExcelDoForVB1　
'数据填入Excel单元格打印
　　　　　　　　　　PageN = PageN + 1
　　　　　　　　Loop
　　　　　　Case 2
　　　　　　……
　　　　　　……
　　　　End Select
　　Else
　　　　If Flag = 2 Then　　'
当打印对话框中选"页"时
　　　　　　If EndPage - BeginPage = 0 Then
　　　　　　　　ifNum = 0
　　　　　　Else
　　　　　　　　If EndPage - BeginPage > 0 Then
　　　　　　　　　　ifNum = 1
　　　　　　　　Else
　　　　　　　　　　ifNum = 2
　　　　　　　　End If
　　　　　　End If
　　　　　　Select Case ifNum
　　　　　　　　Case 2
　　　　　　　　　　Exit Sub
　　　　　　　　Case 0
　　　　　　　　　　Select Case Opt　　 '
选择需要打印的表格
　　　　　　　　　　　　Case 1
myrecordset1.MoveFirst
n = (BeginPage - 1) *
(49 - 4 + 1) - 1
myrecordset1.Move n
PageN = BeginPage
Call ExcelDoForVB1
　'数据填入Excel单元格并打印
　　　　　　　　　　　　Case 2
　　　　　　　　　　　　……
　　　　　　　　　　　　……
　　　　　　　　　　　　End Select
　　　　　　　　 Case 1
　　　　　　　　　　Select Case Opt　　　
'选择需要打印的表格
　　　　　　　　　　　　Case 1
myrecordset1.MoveFirst
n = (BeginPage - 1) *
(49 - 4 + 1) - 1
myrecordset1.Move n
PageN = BeginPage
For nBtoE = BeginPage To EndPage
　　Call ExcelDoForVB1　
'填入Excel单元格并打印
　　PageN = PageN + 1
Next nBtoE
　　　　　　　　　　　　Case 2
　　　　　　　　　　　　……
　　　　　　　　　　　　……
　　　　　　　　　　　　End Select
　　　　　　End Select
　　　　End If
　　End If
　　FrmMain.Visible = True
　　Exit Sub
errhandle:
　　FrmPrint.Visible = False
FrmMain.Visible = True
End Sub

---- 注意，下段仅通过ExcelDoForVB1()对"报表（一）"的处理，来说明数据填入Excel并打印的整个过程。

Sub ExcelDoForVB1()　　　　　 '打印报表（一）
　　FrmPrint.Visible = True
　　Set exsheet = exwbook.Worksheets("sheet1")
　　ex.Sheets("Sheet1").Select
　　ex.Range("A4:U49").Select
　　ex.Selection.ClearContents
　　ex.Range("A4").Select
　　bar1.Min = 0　　　　　　
　　bar1.Max = 45　　　　　
　　For nRow = 4 To 49
　　bar1.Value = nRow - 4　　 '进度显示栏进程
　　　　myrecordset1.MoveNext
　　　　If myrecordset1.EOF Then
　　　　　　nflag = 0
　　　　　　Exit For
　　　　End If
　　　　For nCol = 1 To 21
　　　　　　exsheet.Cells(nRow, nCol) =
myrecordset1.Fields(nCol - 1)
　　　　Next nCol
　　Next nRow
　　exsheet.Cells(52, 21) = "第 " + CStr(PageN) + " 页"
　　FrmPrint.Visible = False
　　bar1.Value = 0
ActiveWindow.SelectedSheets.PrintOut Copies:=NumCopies
End Sub

[yijn]

火山的程序我在网上看过了，并且也试验过了。有如下问题
一方面实施时灵活性不够，无法处理EXCEL中的长字符，并且要求ACCESS中的数据库文件的结构要求很死，无法达到要求！
二方面要用ADO调用，否则效率很低的！
火山的得分为50分，网络咖啡的得分为80分。请进入
http://www.csdn.net/expert/topic/572/572900.xml
登记以便给分

[daryl715]

由VB提供的DataManager对于开发人员来讲并不是一件强大的工具。对于那些没有
装Access数据库的人来说，在开发
时建立．改变或重构数据库，以及载入／重载表单都是一件痛苦的事。此外
DataManager不能让我们打印数据库的结构。

让我们编一个小程序实现上述功能，然后工程结束后把它抛弃.

首先可以用一个以逗号分隔的文本文件来储存表结构，如下面这个人员表。

lPersonID,Long,,person's ID
sPersonFirstName,Text,20,person's first name
sPersonLastName,Text,20,person's last name
bIsAFunPerson,Boolean,,invite to a party?
iTypeOfJob,Integer,,0=None 1=Manual 2=Office 3=programmer etc.
iAge,Integer,,person's age

该表有六列，每列独占一行。每行中用逗号分隔下列各项：字段名．字段类型．字
段长度（如果不是字符型字段，就留空，仅用逗号
分隔）及字段描述。如果你想在字段描述中使用逗号，你可以不用逗号分隔各项，
换成Tab分隔。

一个通用程序能读取这些文件并根据它们建立起数据库。这种方法，连同一些通用
的导入／导出程序能大大加快程序开发的速度。举例 来说，你不能在DM中删除一
个表的一列，但通过删除CSV文件中对一列的定义，然后重新运行构建数据库的程
序，你就能轻松做到这一点。

如果你想打印出数据库的结构，方法也很简单：用Excel读CSV文件，再将其粘贴到
Word中，这样你就可以打印出整个数据库的结构了。

下面是程序代码：

Sub CreateTable (sDatabaseName As String, sCSVFileName As String,
sTableName As String)
Dim iTemp As Integer
'将控制权交还给操作系统，使其在创建数据库的同时能运行其它程序－别让
你的计算机闲着！
iTemp = DoEvents()
'创建一个300X3数组
ReDim sTables(300, 3) As String
Dim sDataTypeLine As String

' 读取CSV文件，并将字段定义保存在数组中
Call ReadTableDefinition(sCSVFileName, sTables())

Dim tbl As New TableDef
Dim fld As Field

'打开数据库
Dim dbPersons As database
Set dbPersons = OpenDatabase(sDatabaseName & ".MDB", True)



'记录下新的表单名
tbl.Name = sTableName

'增添第一个字段
Set fld = New Field
fld.Name = sTables(1, 1)
fld.Type = GetFieldType((sTables(1, 2)))
fld.Size = Val(sTables(1, 3))
tbl.Fields.Append fld


dbPersons.TableDefs.Append tbl

'增加其它的字段
Dim iNextCol As Integer
iNextCol = 1
Do While True
Set fld = New Field
iNextCol = iNextCol + 1
'到了表定义的底部则退出
If sTables(iNextCol, 1) = "***END***" Then
Exit Do
End If
fld.Name = sTables(iNextCol, 1)
fld.Type = GetFieldType((sTables(iNextCol, 2)))
fld.Size = Val(sTables(iNextCol, 3))
'增加字段
dbPersons.TableDefs(tbl.Name).Fields.Append fld
'write field to VB data declaration file
'sDataTypeLine = Chr$(9) & sTables(iNextCol, 1) & " As " &
GetDataType((sTables(iNextCol, 2)))
'If GetDataType((sTables(iNextCol, 2))) = "String" Then
' sDataTypeLine = sDataTypeLine & " * " & Val(sTables(iNextCol,
3))
'End If
'Print #2, sDataTypeLine

Loop

'close database
dbPersons.Close




End Sub

Sub ReadTableDefinition (sTableFileName As String, sTableArray() As
String)

' sTableFileName为CSV文件名
' sTableArray 是一个空的300行X3列的数组
' 3列中储存字段名．数据类型及字段长度的信息
' 一个表中可能会有多达300个字段，虽然这不太可能
' 你可以重新定义该数组

' 打开CSV文件
Open sTableFileName For Input As #1
Dim sNextLine As String, sColName As String, sColType As String,
sColLength As String
Dim iFirstComma As Integer, iSecondComma As Integer, iThirdComma As
Integer, iTableArrayIndex As Integer
iTableArrayIndex = 0
' 读取所有列的定义
Do While Not EOF(1)
Line Input #1, sNextLine
sNextLine = Trim$(sNextLine)
If sNextLine <> "" Then
If sNextLine <> "" And Mid$(sNextLine, 1, 2) <> "/*" Then
iFirstComma = InStr(1, sNextLine, ",")
iSecondComma = InStr(iFirstComma + 1, sNextLine, ",")
iThirdComma = InStr(iSecondComma + 1, sNextLine, ",")
iTableArrayIndex = iTableArrayIndex + 1
'获取字段名
sTableArray(iTableArrayIndex, 1) = Trim$(Mid$(sNextLine,
1, iFirstComma - 1))
'获取字段类型
sTableArray(iTableArrayIndex, 2) = UCase$(Trim$(Mid$(
sNextLine, iFirstComma + 1, iSecondComma - iFirstComma - 1)))
'获取字段长度
sTableArray(iTableArrayIndex, 3) = Trim$(Mid$(sNextLine,
iSecondComma + 1, iThirdComma - iSecondComma - 1))
End If
End If
Loop

Close #1

'标记数组结束
iTableArrayIndex = iTableArrayIndex + 1
sTableArray(iTableArrayIndex, 1) = "***END***"

End Sub

'转换数据类型
Function GetFieldType(ByVal TypeName As String) As Integer
Select Case LCase(TypeName)
Case "string"
GetFieldType = dbText
其它的代码自己完成吧
End Select