VB写excel方法

以下我写的一个把记录集中的数据导出到EXCEL函数。看看如何，不好处请修改
'=======================================================================
'功能：将数据库中的记录导出为Excel文件
'输入：Rst 数据库记录集 StrTitle Excel文件标题
'=======================================================================

Public Function RstToExcel(ByVal Rst As ADODB.Recordset, Optional ByVal StrTitle As String = "数据列表 ")
Dim ObjExcel As Excel.Application '定义Excel对象
Dim ObjWorkBook As Excel.Workbook '定义工作薄
Dim ObjSheet As Excel.Worksheet '定义工作表
Dim ObjRange As Excel.Range '定主用户使用工作表范围

Dim i As Integer, j As Integer
Dim iCol As Integer, iRow As Integer '取得Excel的行和列
Dim iChr As Integer '用来取得工作表中最后一个列的字符名，如K列
Dim StrChr As String

On Error GoTo err
Screen.MousePointer = vbHourglass '开始写入文件，处于等待中

If Not (Rst.EOF And Rst.BOF) Then
Rst.MoveLast
Rst.MoveFirst
iRow = Rst.RecordCount + 1 '设置Excel的行数
iCol = Rst.Fields.Count '设置Excel的列数
End If

Set ObjExcel = New Excel.Application '建立一个新的Excel对象
'添加新的工作薄和新的工作表
Set ObjWorkBook = ObjExcel.Workbooks.Add
Set ObjSheet = ObjExcel.Worksheets.Add

'取得最未列字母
iChr = Asc( "A ") + iCol - 1
StrChr = Chr(iChr) & 2

For j = 1 To iCol
With Rst.Fields(j - 1)
If .Type = adChar Or .Type = adVarChar Then
'如是字符型字段，比较字段名的长度与定义的长度取其长的设为列宽（此处用于中英文混合比较）
If LenB(StrConv(.name, vbFromUnicode)) > .DefinedSize Then
ObjSheet.Columns(j).ColumnWidth = LenB(StrConv(.name, vbFromUnicode))
Else
ObjSheet.Columns(j).ColumnWidth = .DefinedSize
End If
ElseIf .Type = adDouble Or .Type = adInteger Or .Type = adSingle Or .Type = adNumeric Or .Type = adSmallInt Then

'如是数据型的字段取字段名的长度为列宽
ObjSheet.Columns(j).ColumnWidth = LenB(StrConv(.name, vbFromUnicode))
ElseIf .Type = adDate Or .Type = adDBDate Or .Type = adDBTime Or .Type = adDBTimeStamp Then
ObjSheet.Columns(j).ColumnWidth = 15
End If
End With
Next

'设置要操作的Excel的范围从单元格A1到指定列数单元格处
Set ObjRange = ObjSheet.Range( "A1: " & StrChr) '用A1到StrChr之间的行数用来写入标题
ObjRange.Merge
With ObjRange
https://www.wendangku.net/doc/0f3586697.html, = "黑体 "
.Font.Size = 15
.Cells(1, 1) = Trim$(StrTitle)
'使标题居中
.Cells.HorizontalAlignment = xlCenter
.Cells.VerticalAlignment = xlCenter
End With

'重设要操作的工作表范围，用数写入记录集中的数据
Set ObjRange = ObjSheet.Range( "A3 ") '从A3开始写入数据
With ObjRange
https://www.wendangku.net/doc/0f3586697.html, = "宋体 "
.Font.Size = 12
'利用行列循环，向单元格写入数据，并指定了其格式
For i = 1 To iRow
For j = 1 To iCol
If i = 1 Then '第一行写表头
.Cells(i, j) = Rst.Fields(j - 1).name
.Cells(i, j).HorizontalAlignment = xlCenter
Else
With Rst.Fields(j - 1)
If .Type = adChar Or .Type = adVarChar Then
'转化类型，因为Excel默认为数据类型，如不转化当字符串中首字符是0时就会自动截去
ObjRange.Cells(i, j).NumberFormatLocal = "@ "
ObjRange.Cells(i, j) = CStr(Trim$(.value))
ObjRange.Cells(i, j).HorizontalAlignment = xlCenter '单元格数据水平居中
ElseIf .Type = adDouble Or .Type = adInteger Or .Type = adSingle Or .Type = adNumeric Or .Type = adSmallInt Then
ObjRange.Cells(i, j) = .value
ObjRange.Cells(i, j).HorizontalAlignment = xlCenter
Else

ObjRange.Cells(i, j) = .value
ObjRange.Cells(i, j).HorizontalAlignment = xlCenter
End If
End With
End If
Next j
'i比记录数多了1个，因此从i=2开始移动记录
If i > 1 Then Rst.MoveNext
Next i
End With
'ObjWorkBook.SaveAs
ObjExcel.Visible = True
'写完文件，恢复状态
Screen.MousePointer = vbDefault
Exit Function
err:
MsgBox err.Number & Space(3) & err.Description, vbInformation
Screen.MousePointer = vbDefault
'释放资源
ObjWorkBook.Close
Set ObjSheet = Nothing
Set ObjWorkBook = Nothing
Set ObjExcel = Nothing
End Function