VB实现Access导出到Excel，Excel导出到Access的功能

*******************************************************************************************************************

以下是从Excel导入到Access的代码：

Private Sub cmd_ImportData_Click()

    Dim cn As ADODB.Connection

    Dim rs As ADODB.Recordset

    Dim cnStr1 As String, rsStr As String

    cnStr1 = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & txt_Path.Text & ";Extended Properties='Excel 8.0;HDR=Yes'"

    rsStr = "select * from [Sheet1$]"

    

    Set cn = New ADODB.Connection

    Set rs = New ADODB.Recordset

    cn.CursorLocation = adUseClient

    cn.Open cnStr1

    rs.Open rsStr, cn

    ImportData rs

    rs.MoveFirst

End Sub

Sub ImportData(Rs1 As ADODB.Recordset)   '导出数据到access表

    Dim cn As ADODB.Connection

    Dim rs As ADODB.Recordset

    Dim rsStr As String

    On Error GoTo ErrDlog

    Set cn = New ADODB.Connection

    Set rs = New ADODB.Recordset

    

    cn.Open cnStr

    rsStr = "select * from T_Data"

    cn.Execute ("delete * from T_Data")   '清除原有数据

    rs.Open rsStr, cn, adOpenStatic, adLockOptimistic

    Do While Not Rs1.EOF

        rs.AddNew

        For i = 0 To Rs1.Fields.Count - 1

            rs.Fields(i) = Rs1.Fields(i)

        Next

        rs.Update

        Rs1.MoveNext

    Loop

    MsgBox "数据导入成功!", , "恭喜"

    rs.Close

    cn.Close

    Exit Sub

ErrDlog:

    MsgBox "错误描述：" & Err.Description & vbCrLf & "错误代码：" & Err.Number, vbCritical + vbOKOnly, "注意"

End Sub

*******************************************************************************************************************

以下是Access导出到Excel的代码

Private Sub cmd_ExportExcel_Click()

    Dim FileName As String

    Dim FilePath As String

    

    Dim Conn As New ADODB.Connection

    

    On Error GoTo err1

    frm_StoreName.Show vbModal

    

If StoreName_Flg = True Then

    

    Text1(0).Text = StoreName

    

    FilePath = App.Path & "\店铺信息数据文件夹"

    

    If Dir(FilePath, vbDirectory) = "" Then

        MkDir FilePath

    End If

    

    FileName = FilePath & "\" & StoreName & ".xls"

    

    If Dir(FileName) <> "" Then

        'MsgBox "文件已经存在,请重新输入!"

        Kill FileName

    End If

    

    Set Conn = New ADODB.Connection

    Conn.ConnectionString = 30

    Conn.CommandTimeout = 58

    Conn.CursorLocation = adUseClient

    Conn.Open cnStr

    

    Conn.Execute ("select * into [Sheet1] IN '" & FileName & "' 'EXCEL 8.0;'  from [T_Info] where b like '" & StoreName & "'")

    MsgBox "数据导出完成!", , "恭喜"

    Conn.Close

    Exit Sub

    

Else

    Exit Sub

End If

err1:

    MsgBox "错误描述：" & Err.Description & vbCrLf & "错误代码：" & Err.Number, vbCritical + vbOKOnly, "注意"

End Sub

 

*******************************************************************************************************************