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的内容，然后判断，处理

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

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

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

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

---- 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

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

由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