如果你想将查询结果导出到Excel另存，以便日后查看或打印的话，那么我这里说的就是怎样将查询结果导出到Excel。先来写一个函数FillDataArray，该函数的主要作用是将查询语句中的字段名和查到的记录导入到Excel中。
Public Function FillDataArray(asArray(), adoRS As ADODB.Recordset) As Long
'将数据送 Excel 函数
Dim nRow As Integer
Dim nCol As Integer
On Error GoTo FillError
ReDim asArray(100000, adoRS.Fields.Count)
nRow = 0
For nCol = 0 To adoRS.Fields.Count - 1
asArray(nRow, nCol) = adoRS.Fields(nCol).Name
Next nCol
nRow = 1
Do While Not adoRS.EOF
For nCol = 0 To adoRS.Fields.Count - 1
asArray(nRow, nCol) = adoRS.Fields(nCol).Value
Next nCol
adoRS.MoveNext
nRow = nRow + 1
Loop
nRow = nRow + 1
FillDataArray = nRow
Exit Function
FillError:
MsgBox Error$
Exit Function
Resume
End Function
然后再来写一个过程PrintList，来调用前面的这个函数。
Private Sub PrintList()
Dim strSource, strDestination As String
Dim asTempArray()
Dim INumRows As Long
Dim objExcel As Excel.Application
Dim objRange As Excel.Range
On Error GoTo ExcelError
Set objExcel = New Excel.Application '新建一个Excel
Dim rs As New ADODB.Recordset
Set rs = Conn.Execute(sqlall)‘sqlall是查询语句
If Not rs.EOF Then
objExcel.Workbooks.Open App.Path & "\vvv.xls"
MsgBox "查询结果导出后，请将其另存为一个.xls文件，使vvv.xls中的内容为空，确保后面查询结果的正确导出。"
INumRows = FillDataArray(asTempArray, rs) '调填充数组函数
objExcel.Cells(1, 1) = "查询结果" '填表头
Set objRange = objExcel.Range(objExcel.Cells(2, 1), objExcel.Cells(INumRows, rs.Fields.Count))
objRange.Value = asTempArray '填数据
End If
objExcel.Visible = True '显示Excel
objExcel.DisplayAlerts = True '提示保存Excel
Exit Sub
ExcelError:
If Err <> 432 And Err > 0 Then
MsgBox Error$
Set objExcel = Nothing
Exit Sub
Else
Resume Next
End If
End Sub
其中用到的vvv.xls必须是先建好了的xls文件。结果导出后不要直接保存，而要将其另存为一个.xls文件，使vvv.xls中的内容为空，确保后面查询结果的正确导出。
