2011-07-25 16:43:23|  分类： |字号 

 

 

把excel中的数据导入SQL SERVER数据库（access数据类似）：

Private Sub Command1_Click()

Dim strconn As String ' 定义Excel 连接字符串

Dim cn As ADODB.Connection ' 定义Excel 连接

Set cn = New ADODB.Connection

' 初始化commandialog1 的属性，选取Excel 文件，文

' 件名保存在CommanDialog1.filename 中备用

CommonDialog1.Filter = " 电子表格文件(.xls) |*.xls"

CommonDialog1.DialogTitle = " 请选择要导入的文件"

CommonDialog1.ShowOpen

' 设置连接SQL 数据库的连接字符串

strtemp = " [odbc;Driver= {SQL Server} ;Server=(local);Database=Afws;UID=sa;PWD=sa]"

' 设置Excel 数据连接

strconn = " Provider =Microsoft.Jet.OLEDB.4.0;Data Source=" & CommonDialog1.FileName & " ; Extended Properties=Excel 8.0" 

cn.Open strconn

strSql = "insert into " & strtemp & ".hw_level1 select * from [sheet1$]"

cn.Execute strSql, lngRecsAff, adExecuteNoRecords

MsgBox " 成功导入到SQL 数据库中！", vbExclamation + vbOKOnly

cn.Close

Set cn = Nothing

End Sub

---

从access数据库中导出数据到为excel（sql数据库类似）：

dim conn as adodb.connection

Dim rs1 As New ADODB.Recordset

dim sql as string

set conn=new adodb.connection

if conn.state<>0 then conn.close

conn.open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & App.Path &"\sclsylb.mdb"

sql="SELECT * FROM QS800"      'QS800表你应该很熟悉

if rs1.state<>0 then rs1.close

rs1.cursorlocation=aduserclient

rs1.open sql,conn,1,3

'导出xls表

Dim xlApp     As New Excel.Application

Dim xlBook     As Excel.Workbook

Dim xlSheet     As Excel.Worksheet

Dim xlQuery     As Excel.QueryTable

'On Error GoTo OutPutErr

Set xlBook = xlApp.Workbooks().Add

Set xlSheet = xlBook.Worksheets("sheet1")

Set xlQuery = xlSheet.QueryTables.Add(rs1, xlSheet.Range("a1 "))

With xlQuery

        .FieldNames = True

        .RowNumbers = False

        .FillAdjacentFormulas = False

        .PreserveFormatting = True

        .RefreshOnFileOpen = False

        .BackgroundQuery = True

        .RefreshStyle = xlInsertDeleteCells

        .SavePassword = True

        .SaveData = True

        .AdjustColumnWidth = True

        .RefreshPeriod = 0

        .PreserveColumnInfo = True

End With

xlQuery.FieldNames = True

xlQuery.Refresh

cmdlg.Flags = 2

cmdlg.Filter = "EXCEL文档(*.xls)"

cmdlg.ShowSave

If cmdlg.FileName <> "" Then

    xlApp.DisplayAlerts = False

    xlBook.SaveAs FileName:=cmdlg.FileName

    If MsgBox("导出成功,是否打开查看?", vbOKCancel, "导出EXCEL") = vbOK Then

        xlApp.Workbooks().Open cmdlg.FileName

        xlApp.Visible = True

    Else

        xlApp.Quit

    End If

End If

If xlApp <> Null Then Set xlApp = Nothing

set conn=nothing

set rs1=nothing