vb将excel数据导入mysql_VB将excel数据导入数据库以及将数据库数据导入excel源代码 .: NOVOTS KMS...

Private Sub Command11_Click()

Dim conn

Dim conn2

Dim a As String

With CommonDialog1

.Filter = "EXCEL文件[*.XLS]|*.xls"

.ShowOpen

a = .FileName

Text2.Text = a

End With

Set conn = CreateObject("ADODB.Connection")

conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=;Persist Security Info=False;Data Source=" & App.Path + "\database.mdb " & ""

Set conn2 = CreateObject("ADODB.Connection")

conn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=;Extended properties='Excel 8.0;HDR=Yes;IMEX=1';Data Source=" & Text2.Text & ""

SQL = "SELECT * FROM [Sheet1$]"

Set rs = conn2.Execute(SQL)

While Not rs.EOF

SQL = "insert into 合同管理表 ([姓名],[性别],[部门],[签订时间],[签订次数],[合同期限]) values('" & fixsql(rs(0)) & "','" & fixsql(rs(1)) & "','" & fixsql(rs(2)) & "','" & fixsql(rs(3)) & "','" & fixsql(rs(4)) & "','" & fixsql(rs(5)) & "')"

conn.Execute (SQL)

rs.MoveNext

Wend

conn.Close

Set conn = Nothing

conn2.Close

Set conn2 = Nothing

Adodc1.Refresh

DataGrid1.Refresh

End Sub

Function fixsql(str)

Dim newstr

newstr = str

If IsNull(newstr) Then

newstr = ""

Else

newstr = Replace(newstr, "'", "''")

End If

fixsql = newstr

End Function

将数据库数据导入excel：

Private Sub Command6_Click()

Set xlApp = CreateObject("excel.application")

Set xlBook = xlApp.Workbooks.Add

Set xlSheet = xlBook.Worksheets(1)

xlApp.Visible = True '设置EXCEL可见

On Error Resume Next

If Err.Number <> 0 Then Set xlApp = CreateObject("Excel.Application")

Set xlBook = xlApp.Workbooks.Add

Set xlSheet = xlBook.ActiveSheet

For k = 1 To DataGrid1.Columns.Count

xlSheet.Cells(1, k) = DataGrid1.Columns(k - 1).Caption

Next k

For I = 1 To Adodc1.Recordset.RecordCount + 1

For j = 0 To DataGrid1.Columns.Count

xlSheet.Cells(I + 1, j + 1) = Adodc1.Recordset(j) '

Next j

Adodc1.Recordset.MoveNext

Next I

end sub