VB之Access与Excel互导代码

以下是从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