Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Set xlBook = xlApp.Workbooks.Add
Set xlsheet = xlBook.Worksheets(1)
xlsheet.Activate
n = AdoData.RecordCount
M = AdoData.Fields.Count
i = 2
If AdoData.RecordCount > 0 Then
AdoData.MoveFirst
End If
Do While Not AdoData.EOF
J = 0
Do
xlsheet.Cells(1, J + 1) = DataGrid1.Columns(J).Caption
xlsheet.Cells(i, J + 1) = DataGrid1.Columns(J)
J = J + 1
Loop While J < M
AdoData.MoveNext
i = i + 1
StatusBar1.Panels(1).Text = "已导出了" & i - 1 & "/" & n & "条信息,请稍候……"
Loop
StatusBar1.Panels(1).Text = "导出数据成功！共导出了" & n & "个订单数据！"
xlBook.Close
Set xlApp = Nothing
Set xlBook = Nothing
Set xlsheet = Nothing
今天使用别人的软件，发现导出到EXCEL速度很快啊。不知道用的什么方法？
在网上看见有人说用
cn.execute "master..xp_cmdshell 'bcp "SELECT col1, col2 FROM 库名.dbo.表名" queryout E:\DT.xls -c -Sservername -Usa -Ppassword'"
看不懂啊，能解说一下么？
4 个解决方案
#1
经实际测试，以下代码数据库和Excel之间互相导入导出，完全成功！
Private Sub Command1_Click()
'access导出到excel
Dim db As New ADODB.Connection
Dim sPath As String
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\Temp\Test\db1.mdb Persist Security Info=False"
sPath = App.Path + "\backup.xls"
If Dir(sPath) <> "" Then
Kill sPath
Else
Call db.Execute("select * into Sheet1 In '" & sPath & "' 'excel 8.0;' from 表1")
MsgBox "导出成功", vbOKOnly, "提示"
End If
db.Close
Set db = Nothing
End Sub
Private Sub Command2_Click()
'从excel导出到 access
Dim db As New ADODB.Connection
Dim sPath As String
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\Temp\Test\db1.mdb;Persist Security Info=False"
sPath = App.Path + "\backup.xls"
Call db.Execute("select * into Table4 From [Sheet1$] In '" & sPath & "' 'excel 8.0;'")
db.Close
Set db = Nothing
End Sub
Private Sub Command1_Click()
'access导出到excel
Dim db As New ADODB.Connection
Dim sPath As String
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\Temp\Test\db1.mdb Persist Security Info=False"
sPath = App.Path + "\backup.xls"
If Dir(sPath) <> "" Then
Kill sPath
Else
Call db.Execute("select * into Sheet1 In '" & sPath & "' 'excel 8.0;' from 表1")
MsgBox "导出成功", vbOKOnly, "提示"
End If
db.Close
Set db = Nothing
End Sub
Private Sub Command2_Click()
'从excel导出到 access
Dim db As New ADODB.Connection
Dim sPath As String
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\Temp\Test\db1.mdb;Persist Security Info=False"
sPath = App.Path + "\backup.xls"
Call db.Execute("select * into Table4 From [Sheet1$] In '" & sPath & "' 'excel 8.0;'")
db.Close
Set db = Nothing
End Sub
#2
我在查询的页面上有很多选项可以选，但所有查询后的结果都显示在datagrid中。所以导出都从datagrid中导出的。
如果按照你说的办法，是不是我应该写很多个分支进行导出呢？
#3
看你自己的选择的方案，我给你的方法是从数据库直接导出到excel，你可以将界面的指定的值作为查询参数然后导出，如果你希望从界面直接转为excel，则需按你自己的方案，创建excel.application对象
#4
'*********************************************************
'* Ãû³Æ£ºExporToExcel'* ¹¦ÄÜ£ºµ¼³öÊý¾Ýµ½EXCEL'* Ó÷¨£ºExporToExcel(sql²éѯ×Ö·û´®)
'*********************************************************
Public Function ExporToExcel(strOpen As String)
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = adoConn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("ûÓмǼ!")
Exit Function
End If '¼Ç¼×ÜÊý
Irowcount = .RecordCount '×Ö¶Î×ÜÊý
Icolcount = .Fields.count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True 'Ìí¼Ó²éѯÓï¾ä£¬µ¼ÈëEXCELÊý¾Ý
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, 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
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "ºÚÌå" 'Éè±êÌâΪºÚÌå×Ö
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True '±êÌâ×ÖÌå¼Ó´Ö
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous 'Éè±í¸ñ±ß¿òÑùʽ
End With
With xlSheet.PageSetup
.LeftHeader = "" & Chr(10) & "&""¿¬Ìå_GB2312,³£¹æ""&10¹«Ë¾Ãû³Æ£º" ' & Gsmc
.CenterHeader = "&""¿¬Ìå_GB2312,³£¹æ""¹«Ë¾ÈËÔ±Çé¿ö±í&""ËÎÌå,³£¹æ""" & Chr(10) & "&""¿¬Ìå_GB2312,³£¹æ""&10ÈÕ ÆÚ£º"
.RightHeader = "" & Chr(10) & "&""¿¬Ìå_GB2312,³£¹æ""&10µ¥Î»£º"
.LeftFooter = "&""¿¬Ìå_GB2312,³£¹æ""&10ÖƱíÈË£º"
.CenterFooter = "&""¿¬Ìå_GB2312,³£¹æ""&10ÖƱíÈÕÆÚ£º"
.RightFooter = "&""¿¬Ìå_GB2312,³£¹æ""&10µÚ&PÒ³ ¹²&NÒ³"
End With
xlApp.Application.Visible = True
Set xlApp = Nothing '"½»»¹¿ØÖƸøExcel
Set xlBook = Nothing
Set xlSheet = Nothing
End Function
瞬间导出excel
由于编码问题，代码中的中文显示不正常，你自己改一下吧！
#1
经实际测试，以下代码数据库和Excel之间互相导入导出，完全成功！
Private Sub Command1_Click()
'access导出到excel
Dim db As New ADODB.Connection
Dim sPath As String
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\Temp\Test\db1.mdb Persist Security Info=False"
sPath = App.Path + "\backup.xls"
If Dir(sPath) <> "" Then
Kill sPath
Else
Call db.Execute("select * into Sheet1 In '" & sPath & "' 'excel 8.0;' from 表1")
MsgBox "导出成功", vbOKOnly, "提示"
End If
db.Close
Set db = Nothing
End Sub
Private Sub Command2_Click()
'从excel导出到 access
Dim db As New ADODB.Connection
Dim sPath As String
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\Temp\Test\db1.mdb;Persist Security Info=False"
sPath = App.Path + "\backup.xls"
Call db.Execute("select * into Table4 From [Sheet1$] In '" & sPath & "' 'excel 8.0;'")
db.Close
Set db = Nothing
End Sub
Private Sub Command1_Click()
'access导出到excel
Dim db As New ADODB.Connection
Dim sPath As String
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\Temp\Test\db1.mdb Persist Security Info=False"
sPath = App.Path + "\backup.xls"
If Dir(sPath) <> "" Then
Kill sPath
Else
Call db.Execute("select * into Sheet1 In '" & sPath & "' 'excel 8.0;' from 表1")
MsgBox "导出成功", vbOKOnly, "提示"
End If
db.Close
Set db = Nothing
End Sub
Private Sub Command2_Click()
'从excel导出到 access
Dim db As New ADODB.Connection
Dim sPath As String
db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=E:\Temp\Test\db1.mdb;Persist Security Info=False"
sPath = App.Path + "\backup.xls"
Call db.Execute("select * into Table4 From [Sheet1$] In '" & sPath & "' 'excel 8.0;'")
db.Close
Set db = Nothing
End Sub
#2
我在查询的页面上有很多选项可以选，但所有查询后的结果都显示在datagrid中。所以导出都从datagrid中导出的。
如果按照你说的办法，是不是我应该写很多个分支进行导出呢？
#3
看你自己的选择的方案，我给你的方法是从数据库直接导出到excel，你可以将界面的指定的值作为查询参数然后导出，如果你希望从界面直接转为excel，则需按你自己的方案，创建excel.application对象
#4
'*********************************************************
'* Ãû³Æ£ºExporToExcel'* ¹¦ÄÜ£ºµ¼³öÊý¾Ýµ½EXCEL'* Ó÷¨£ºExporToExcel(sql²éѯ×Ö·û´®)
'*********************************************************
Public Function ExporToExcel(strOpen As String)
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = adoConn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("ûÓмǼ!")
Exit Function
End If '¼Ç¼×ÜÊý
Irowcount = .RecordCount '×Ö¶Î×ÜÊý
Icolcount = .Fields.count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True 'Ìí¼Ó²éѯÓï¾ä£¬µ¼ÈëEXCELÊý¾Ý
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, 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
With xlSheet
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "ºÚÌå" 'Éè±êÌâΪºÚÌå×Ö
.Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True '±êÌâ×ÖÌå¼Ó´Ö
.Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous 'Éè±í¸ñ±ß¿òÑùʽ
End With
With xlSheet.PageSetup
.LeftHeader = "" & Chr(10) & "&""¿¬Ìå_GB2312,³£¹æ""&10¹«Ë¾Ãû³Æ£º" ' & Gsmc
.CenterHeader = "&""¿¬Ìå_GB2312,³£¹æ""¹«Ë¾ÈËÔ±Çé¿ö±í&""ËÎÌå,³£¹æ""" & Chr(10) & "&""¿¬Ìå_GB2312,³£¹æ""&10ÈÕ ÆÚ£º"
.RightHeader = "" & Chr(10) & "&""¿¬Ìå_GB2312,³£¹æ""&10µ¥Î»£º"
.LeftFooter = "&""¿¬Ìå_GB2312,³£¹æ""&10ÖƱíÈË£º"
.CenterFooter = "&""¿¬Ìå_GB2312,³£¹æ""&10ÖƱíÈÕÆÚ£º"
.RightFooter = "&""¿¬Ìå_GB2312,³£¹æ""&10µÚ&PÒ³ ¹²&NÒ³"
End With
xlApp.Application.Visible = True
Set xlApp = Nothing '"½»»¹¿ØÖƸøExcel
Set xlBook = Nothing
Set xlSheet = Nothing
End Function
瞬间导出excel
由于编码问题，代码中的中文显示不正常，你自己改一下吧！