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