VB export to excel without office

Public Function FieldType(intType)
Select Case intType
Case 20
FieldType = "int"
Case 128
FieldType = "binary"
Case 11
FieldType = "bit"
Case 129
FieldType = "char"
Case 135
FieldType = "datetime"
Case 131
FieldType = "varchar"
Case 5
FieldType = "float"
Case 205
FieldType = "image"
Case 3
FieldType = "int"
Case 6
FieldType = "money"
Case 130
FieldType = "char"
Case 203
FieldType = "text"
Case 131
FieldType = "numeric"
Case 202
FieldType = "varchar"
Case 4
FieldType = "real"
Case 135
FieldType = "datetime"
Case 2
FieldType = "int"
Case 6
FieldType = "money"
Case 204
FieldType = "varchar"
Case 201
FieldType = "text"
Case 128
FieldType = "timestamp"
Case 17
FieldType = "varchar"
Case 72
FieldType = "varchar"
Case 204
FieldType = "varbinary"
Case 200
FieldType = "varchar"
End Select
End Function
Public Sub ExportToExcel(AdoRecordSet As ADODB.Recordset)
On Error GoTo Excel_Err
Dim Excel_Dsn As String
Dim Excel_Conn As New ADODB.Connection
Dim Excel_Adodc As New ADODB.Recordset
Dim mySql As String
Dim i, j, TmpField, FileName
Rem 得到文件名
For i = 0 To 100
If Len(i) = 1 Then
FileName = "C:\Query_0" & i
Else
FileName = "C:\Query_" & i
End If
If Dir(FileName & ".xls", vbHidden) = "" Then
Exit For
End If
Next
FileName = FileName & ".xls"
Excel_Dsn = "DRIVER={Microsoft Excel Driver (*.xls)};DSN='';FIRSTROWHASNAMES=1;READONLY=FALSE;CREATE_DB=""" & FileName & """;DBQ=" & FileName
Excel_Conn.Open Excel_Dsn
With AdoRecordSet
If Not (.EOF And .BOF) Then
mySql = "Create Table [Query] ("
For i = 0 To .Fields.Count - 1
TmpField = FieldType(.Fields(i).Type)
If TmpField = "char" Or TmpField = "varchar" Or TmpField = "nchar" Or TmpField = "nvarchar" Or TmpField = "varbinary" Then
If .Fields(i).DefinedSize >= 256 Then
mySql = mySql & Trim(.Fields(i).Name) & " text,"
Else
mySql = mySql & Trim(.Fields(i).Name) & " " & FieldType(.Fields(i).Type) & "(" & .Fields(i).DefinedSize & ")" & ","
End If
ElseIf TmpField <> "image" Then
mySql = mySql & Trim(.Fields(i).Name) & " " & FieldType(.Fields(i).Type) & ","
End If
Next
mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1)
mySql = mySql & ")"
Rem 创建表名
Excel_Adodc.Open mySql, Excel_Dsn, adOpenDynamic, adLockPessimistic
Rem 插入数据
For i = 0 To .RecordCount - 1
mySql = "Insert into [Query] Values("
For j = 0 To .Fields.Count - 1
TmpField = FieldType(.Fields(j).Type)
Rem Image 不作保存
If TmpField <> "image" Then
If IsNull(.Fields(j).Value) Then
mySql = mySql & "NULL,"
Else
mySql = mySql & "'" & .Fields(j).Value & "',"
End If
End If
Next
mySql = Left(Trim(mySql), Len(Trim(mySql)) - 1)
mySql = mySql & ")"
Excel_Adodc.Open mySql, Excel_Dsn, adOpenDynamic, adLockPessimistic
.MoveNext
Next
MsgBox "系统提示:" & Chr(13) & " 已经将文件保存到 [ " & FileName & " ]", 64, "系统信息:"
End If
End With
Excel_Conn.Close
Set Excel_Conn = Nothing
Set Excel_Adodc = Nothing
Exit Sub
Excel_Err:
MsgBox "发生错误:" & Err.Description & Chr(13) & "错误代码:" & Err.Number, 64, "系统信息:"End Sub

VB极速倒入sql记录到excel表格

极速倒入sql记录到excel表格,19个子段5万条记录只需30秒

在网上看到一段程序,没有使用vba编程将sql数据倒入excel表格,速度极快,贴出于大家共赏.

其主要思想是：将EXCEL作为一个数据库使用，它的名字就是数据库的名字，工作表就是一张数据库中的表。
建立一个工程,引用dao,添加command1,粘贴一下代码
'声明API函数
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'定义变量


Private Sub Command1_Click()
'如果EXCEL文件已经打开,需要先关闭它.

Dim lpClassName As String
Dim lpCaption As String
Dim Handle As Long
lpClassName = "XLMAIN"
lpCaption = "Microsoft Excel - MyExcel.xls"
Handle = FindWindow(lpClassName$, lpCaption$)
If Handle <> 0 Then
MsgBox "请先关闭EXCEL文件!", vbOKOnly + vbInformation, "不能对已经打开的文件进行写操作!"
Exit Sub
End If
'检查EXCEL文件是否存在,如果存在则删除
If Dir(App.Path & "\MyExcel.xls") <> "" Then Kill App.Path & "\MyExcel.xls"
'进行数据转换
Dim dbs As Database
'打开数据库
Set dbs = OpenDatabase("", False, False, "ODBC;DSN=idms;DATABASE=idms;UID=sa;PWD=;") '连接字符串,请根据自己的情况修改
'把数据导入EXCEL
dbs.Execute "SELECT " & "PersonId as 住户编号, Name as 姓名, Sex as 性别," & _
" Birthday as 出生日期, Nation as 民族,NativePlace as 籍贯," & _
" Politics as 政治面貌, IdCard as 身份证号码,Study as 学历," & _
" WorkPlace as 工作单位, WorkPhone as 单位电话, HomePhone as 家庭电话," & _
" MobilePhone as 手机或BP机, CarCard as 车牌号码, StartDate as 入住日期," & _
" Patch as 片区, DepartmentId as 公寓号, UnitNo as 单元号," & _
" RoomId as 房间号, ContractId as 购房合同号 " & " INTO [Excel 8.0;DATABASE=" & App.Path & "\MyExcel.xls].[WorkSheet1] FROM " & "tbl_Tenement"
'关闭数据库对象
dbs.Close
'释放数据库对象
Set dbs = Nothing
'调用EXCEL打开产生的EXCEL表格
Shell "d:\Program Files\Microsoft Office\Office10\EXCEL.EXE " & App.Path & "\MyExcel.xls", vbMaximizedFocus


End Sub


19个字段,5万条记录,只需30-60秒,而采用直接用vba写入cell的方法两万条记录就需 83分钟,提速何止百倍,但这个方法有些局限,小弟水平有限没能解决.希望大家讨论讨论,予以完善.

1、这段代码可能会随即出现“系统不支持选择的排序方式”错误，在增加resume next后解决，请问这是什么问题引发的，能不能排除掉。
2、问一下一张excel表格可以存储多少条记录，我在测试十万条记录的存入时出现“电子表格已满的错误”

欢迎大家讨论，让所有为导入数据到excel的速度困扰的朋友看到这段代码

Visual Basic导出到Excel提速之法

Excel 是一个非常优秀的报表制作软件，用VBA可以控制其生成优秀的报表，本文通过添加查询语句的方法，即用Excel中的获取外部数据的功能将数据很快地从一个查询语句中捕获到EXCEL中,比起往每个CELL里写数据的方法提高许多倍。

将下文加入到一个模块中,屏幕中调用如下ExporToExcel("select * from table")则实现将其导出到EXCEL中

Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
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 = Cn
.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


注:须在程序中引用'Microsoft Excel 9.0 Object Library'和ADO对象,机器必装Excel 2000

本程序在Windows 98/2000,VB 6 下运行通过。